| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282628362846285628662876288628962906291629262936294629562966297629862996300630163026303630463056306630763086309631063116312631363146315631663176318631963206321632263236324632563266327632863296330633163326333633463356336633763386339634063416342634363446345634663476348634963506351635263536354635563566357635863596360636163626363636463656366636763686369637063716372637363746375637663776378637963806381638263836384638563866387638863896390639163926393639463956396639763986399640064016402640364046405640664076408640964106411641264136414641564166417641864196420642164226423642464256426642764286429643064316432643364346435643664376438643964406441644264436444644564466447644864496450645164526453645464556456645764586459646064616462646364646465646664676468646964706471647264736474647564766477647864796480648164826483648464856486648764886489649064916492649364946495649664976498649965006501650265036504650565066507650865096510651165126513651465156516651765186519652065216522652365246525652665276528652965306531653265336534653565366537653865396540654165426543654465456546654765486549655065516552655365546555655665576558655965606561656265636564656565666567656865696570657165726573657465756576657765786579658065816582658365846585658665876588658965906591659265936594659565966597659865996600660166026603660466056606660766086609661066116612661366146615661666176618661966206621662266236624662566266627662866296630663166326633663466356636663766386639664066416642664366446645664666476648664966506651665266536654665566566657665866596660666166626663666466656666666766686669667066716672667366746675667666776678667966806681668266836684668566866687668866896690669166926693669466956696669766986699670067016702670367046705670667076708670967106711671267136714671567166717671867196720672167226723672467256726672767286729673067316732673367346735673667376738673967406741674267436744674567466747674867496750675167526753675467556756675767586759676067616762676367646765676667676768676967706771677267736774677567766777677867796780678167826783678467856786678767886789679067916792679367946795679667976798679968006801680268036804680568066807680868096810681168126813681468156816681768186819682068216822682368246825682668276828682968306831683268336834683568366837683868396840684168426843684468456846684768486849685068516852685368546855685668576858685968606861686268636864686568666867686868696870687168726873687468756876687768786879688068816882688368846885688668876888688968906891689268936894689568966897689868996900690169026903690469056906690769086909691069116912691369146915691669176918691969206921692269236924692569266927692869296930693169326933693469356936693769386939694069416942694369446945694669476948694969506951695269536954695569566957695869596960696169626963696469656966696769686969697069716972697369746975697669776978697969806981698269836984698569866987698869896990699169926993699469956996699769986999700070017002700370047005700670077008700970107011701270137014701570167017701870197020702170227023702470257026702770287029703070317032703370347035703670377038703970407041704270437044704570467047704870497050705170527053705470557056705770587059706070617062706370647065706670677068706970707071707270737074707570767077707870797080708170827083708470857086708770887089709070917092709370947095709670977098709971007101710271037104710571067107710871097110711171127113711471157116711771187119712071217122712371247125712671277128712971307131713271337134713571367137713871397140714171427143714471457146714771487149715071517152715371547155715671577158715971607161716271637164716571667167716871697170717171727173717471757176717771787179718071817182718371847185718671877188718971907191719271937194719571967197719871997200720172027203720472057206720772087209721072117212721372147215721672177218721972207221722272237224722572267227722872297230723172327233723472357236723772387239724072417242724372447245724672477248724972507251725272537254725572567257725872597260726172627263726472657266726772687269727072717272727372747275727672777278727972807281728272837284728572867287728872897290729172927293729472957296729772987299730073017302730373047305730673077308730973107311731273137314731573167317731873197320732173227323732473257326732773287329733073317332733373347335733673377338733973407341734273437344734573467347734873497350735173527353735473557356735773587359736073617362736373647365736673677368736973707371737273737374737573767377737873797380738173827383738473857386738773887389739073917392739373947395739673977398739974007401740274037404740574067407740874097410741174127413741474157416741774187419742074217422742374247425742674277428742974307431743274337434743574367437743874397440744174427443744474457446744774487449745074517452745374547455745674577458745974607461746274637464746574667467746874697470747174727473747474757476747774787479748074817482748374847485748674877488748974907491749274937494749574967497749874997500750175027503750475057506750775087509751075117512751375147515751675177518751975207521752275237524752575267527752875297530753175327533753475357536753775387539754075417542754375447545754675477548754975507551755275537554755575567557755875597560756175627563756475657566756775687569757075717572757375747575757675777578757975807581758275837584758575867587758875897590759175927593759475957596759775987599760076017602760376047605760676077608760976107611761276137614761576167617761876197620762176227623762476257626762776287629763076317632763376347635763676377638763976407641764276437644764576467647764876497650765176527653765476557656765776587659766076617662766376647665766676677668766976707671767276737674767576767677767876797680768176827683768476857686768776887689769076917692769376947695769676977698769977007701770277037704770577067707770877097710771177127713771477157716771777187719772077217722772377247725772677277728772977307731773277337734773577367737773877397740774177427743774477457746774777487749775077517752775377547755775677577758775977607761776277637764776577667767776877697770777177727773777477757776777777787779778077817782778377847785778677877788778977907791779277937794779577967797779877997800780178027803780478057806780778087809781078117812781378147815781678177818781978207821782278237824782578267827782878297830783178327833783478357836783778387839784078417842784378447845784678477848784978507851785278537854785578567857785878597860786178627863786478657866786778687869787078717872787378747875787678777878787978807881788278837884788578867887788878897890789178927893789478957896789778987899790079017902790379047905790679077908790979107911791279137914791579167917791879197920792179227923792479257926792779287929793079317932793379347935793679377938793979407941794279437944794579467947794879497950795179527953795479557956795779587959796079617962796379647965796679677968796979707971797279737974797579767977797879797980798179827983798479857986798779887989799079917992799379947995799679977998799980008001800280038004800580068007800880098010801180128013801480158016801780188019802080218022802380248025802680278028802980308031803280338034803580368037803880398040804180428043804480458046804780488049805080518052805380548055805680578058805980608061806280638064806580668067806880698070807180728073807480758076807780788079808080818082808380848085808680878088808980908091809280938094809580968097809880998100810181028103810481058106810781088109811081118112811381148115811681178118811981208121812281238124812581268127812881298130813181328133813481358136813781388139814081418142814381448145814681478148814981508151815281538154815581568157815881598160816181628163816481658166816781688169817081718172817381748175817681778178817981808181818281838184818581868187818881898190819181928193819481958196819781988199820082018202820382048205820682078208820982108211821282138214821582168217821882198220822182228223822482258226822782288229823082318232823382348235823682378238823982408241824282438244824582468247824882498250825182528253825482558256825782588259826082618262826382648265826682678268826982708271827282738274827582768277827882798280828182828283828482858286828782888289829082918292829382948295829682978298829983008301830283038304830583068307830883098310831183128313831483158316831783188319832083218322832383248325832683278328832983308331833283338334833583368337833883398340834183428343834483458346834783488349835083518352835383548355835683578358835983608361836283638364836583668367836883698370837183728373837483758376837783788379838083818382838383848385838683878388838983908391839283938394839583968397839883998400840184028403840484058406840784088409841084118412841384148415841684178418841984208421842284238424842584268427842884298430843184328433843484358436843784388439844084418442844384448445844684478448844984508451845284538454845584568457845884598460846184628463846484658466846784688469847084718472847384748475847684778478847984808481848284838484848584868487848884898490849184928493849484958496849784988499850085018502850385048505850685078508850985108511851285138514851585168517851885198520852185228523852485258526852785288529853085318532853385348535853685378538853985408541854285438544854585468547854885498550855185528553855485558556855785588559856085618562856385648565856685678568856985708571857285738574857585768577857885798580858185828583858485858586858785888589859085918592859385948595859685978598859986008601860286038604860586068607860886098610861186128613861486158616861786188619862086218622862386248625862686278628862986308631863286338634863586368637863886398640864186428643864486458646864786488649865086518652865386548655865686578658865986608661866286638664866586668667866886698670867186728673867486758676867786788679868086818682868386848685868686878688868986908691869286938694869586968697869886998700870187028703870487058706870787088709871087118712871387148715871687178718871987208721872287238724872587268727872887298730873187328733873487358736873787388739874087418742874387448745874687478748874987508751875287538754875587568757875887598760876187628763876487658766876787688769877087718772877387748775877687778778877987808781878287838784878587868787878887898790879187928793879487958796879787988799880088018802880388048805880688078808880988108811881288138814881588168817881888198820882188228823882488258826882788288829883088318832883388348835883688378838883988408841884288438844884588468847884888498850885188528853885488558856885788588859886088618862886388648865886688678868886988708871887288738874887588768877887888798880888188828883888488858886888788888889889088918892889388948895889688978898889989008901890289038904890589068907890889098910891189128913891489158916891789188919892089218922892389248925892689278928892989308931893289338934893589368937893889398940894189428943894489458946894789488949895089518952895389548955895689578958895989608961896289638964896589668967896889698970897189728973897489758976897789788979898089818982898389848985898689878988898989908991899289938994899589968997899889999000900190029003900490059006900790089009901090119012901390149015901690179018901990209021902290239024902590269027902890299030903190329033903490359036903790389039904090419042904390449045904690479048904990509051905290539054905590569057905890599060906190629063906490659066906790689069907090719072907390749075907690779078907990809081908290839084908590869087908890899090909190929093909490959096909790989099910091019102910391049105910691079108910991109111911291139114911591169117911891199120912191229123912491259126912791289129913091319132913391349135913691379138913991409141914291439144914591469147914891499150915191529153915491559156915791589159916091619162916391649165916691679168916991709171917291739174917591769177917891799180918191829183918491859186918791889189919091919192919391949195919691979198919992009201920292039204920592069207920892099210921192129213921492159216921792189219922092219222922392249225922692279228922992309231923292339234923592369237923892399240924192429243924492459246924792489249925092519252925392549255925692579258925992609261926292639264926592669267926892699270927192729273927492759276927792789279928092819282928392849285928692879288928992909291929292939294929592969297929892999300930193029303930493059306930793089309931093119312931393149315931693179318931993209321932293239324932593269327932893299330933193329333933493359336933793389339934093419342934393449345934693479348934993509351935293539354935593569357935893599360936193629363936493659366936793689369937093719372937393749375937693779378937993809381938293839384938593869387938893899390939193929393939493959396939793989399940094019402940394049405940694079408940994109411941294139414941594169417941894199420942194229423942494259426942794289429943094319432943394349435943694379438943994409441944294439444944594469447944894499450945194529453945494559456945794589459946094619462946394649465946694679468946994709471947294739474947594769477947894799480948194829483948494859486948794889489949094919492949394949495949694979498949995009501950295039504950595069507950895099510951195129513951495159516951795189519952095219522952395249525952695279528952995309531953295339534953595369537953895399540954195429543954495459546954795489549955095519552955395549555955695579558955995609561956295639564956595669567956895699570957195729573957495759576957795789579958095819582958395849585958695879588958995909591959295939594959595969597959895999600960196029603960496059606960796089609961096119612961396149615961696179618961996209621962296239624962596269627962896299630963196329633963496359636963796389639964096419642964396449645964696479648964996509651965296539654965596569657965896599660966196629663966496659666966796689669967096719672967396749675967696779678967996809681968296839684968596869687968896899690969196929693969496959696969796989699970097019702970397049705970697079708970997109711971297139714971597169717971897199720972197229723972497259726972797289729973097319732973397349735973697379738973997409741974297439744974597469747974897499750975197529753975497559756975797589759976097619762976397649765976697679768976997709771977297739774977597769777977897799780978197829783978497859786978797889789979097919792979397949795979697979798979998009801980298039804980598069807980898099810981198129813981498159816981798189819982098219822982398249825982698279828982998309831983298339834983598369837983898399840984198429843984498459846984798489849985098519852985398549855985698579858985998609861986298639864986598669867986898699870987198729873987498759876987798789879988098819882988398849885988698879888988998909891989298939894989598969897989898999900990199029903990499059906990799089909991099119912991399149915991699179918991999209921992299239924992599269927992899299930993199329933993499359936993799389939994099419942994399449945994699479948994999509951995299539954995599569957995899599960996199629963996499659966996799689969997099719972997399749975997699779978997999809981998299839984998599869987998899899990999199929993999499959996999799989999100001000110002100031000410005100061000710008100091001010011100121001310014100151001610017100181001910020100211002210023100241002510026100271002810029100301003110032100331003410035100361003710038100391004010041100421004310044100451004610047100481004910050100511005210053100541005510056100571005810059100601006110062100631006410065100661006710068100691007010071100721007310074100751007610077100781007910080100811008210083100841008510086100871008810089100901009110092100931009410095100961009710098100991010010101101021010310104101051010610107101081010910110101111011210113101141011510116101171011810119101201012110122101231012410125101261012710128101291013010131101321013310134101351013610137101381013910140101411014210143101441014510146101471014810149101501015110152101531015410155101561015710158101591016010161101621016310164101651016610167101681016910170101711017210173101741017510176101771017810179101801018110182101831018410185101861018710188101891019010191101921019310194101951019610197101981019910200102011020210203102041020510206102071020810209102101021110212102131021410215102161021710218102191022010221102221022310224102251022610227102281022910230102311023210233102341023510236102371023810239102401024110242102431024410245102461024710248102491025010251102521025310254102551025610257102581025910260102611026210263102641026510266102671026810269102701027110272102731027410275102761027710278102791028010281102821028310284102851028610287102881028910290102911029210293102941029510296102971029810299103001030110302103031030410305103061030710308103091031010311103121031310314103151031610317103181031910320103211032210323103241032510326103271032810329103301033110332103331033410335103361033710338103391034010341103421034310344103451034610347103481034910350103511035210353103541035510356103571035810359103601036110362103631036410365103661036710368103691037010371103721037310374103751037610377103781037910380103811038210383103841038510386103871038810389103901039110392103931039410395103961039710398103991040010401104021040310404104051040610407104081040910410104111041210413104141041510416104171041810419104201042110422104231042410425104261042710428104291043010431104321043310434104351043610437104381043910440104411044210443104441044510446104471044810449104501045110452104531045410455104561045710458104591046010461104621046310464104651046610467104681046910470104711047210473104741047510476104771047810479104801048110482104831048410485104861048710488104891049010491104921049310494104951049610497104981049910500105011050210503105041050510506105071050810509105101051110512105131051410515105161051710518105191052010521105221052310524105251052610527105281052910530105311053210533105341053510536105371053810539105401054110542105431054410545105461054710548105491055010551105521055310554105551055610557105581055910560105611056210563105641056510566105671056810569105701057110572105731057410575105761057710578105791058010581105821058310584105851058610587105881058910590105911059210593105941059510596105971059810599106001060110602106031060410605106061060710608106091061010611106121061310614106151061610617106181061910620106211062210623106241062510626106271062810629106301063110632106331063410635106361063710638106391064010641106421064310644106451064610647106481064910650106511065210653106541065510656106571065810659106601066110662106631066410665106661066710668106691067010671106721067310674106751067610677106781067910680106811068210683106841068510686106871068810689106901069110692106931069410695106961069710698106991070010701107021070310704107051070610707107081070910710107111071210713107141071510716107171071810719107201072110722107231072410725107261072710728107291073010731107321073310734107351073610737107381073910740107411074210743107441074510746107471074810749107501075110752107531075410755107561075710758107591076010761107621076310764107651076610767107681076910770107711077210773107741077510776107771077810779107801078110782107831078410785107861078710788107891079010791107921079310794107951079610797107981079910800108011080210803108041080510806108071080810809108101081110812108131081410815108161081710818108191082010821108221082310824108251082610827108281082910830108311083210833108341083510836108371083810839108401084110842108431084410845108461084710848108491085010851108521085310854108551085610857108581085910860108611086210863108641086510866108671086810869108701087110872108731087410875108761087710878108791088010881108821088310884108851088610887108881088910890108911089210893108941089510896108971089810899109001090110902109031090410905109061090710908109091091010911109121091310914109151091610917109181091910920109211092210923109241092510926109271092810929109301093110932109331093410935109361093710938109391094010941109421094310944109451094610947109481094910950109511095210953109541095510956109571095810959109601096110962109631096410965109661096710968109691097010971109721097310974109751097610977109781097910980109811098210983109841098510986109871098810989109901099110992109931099410995109961099710998109991100011001110021100311004110051100611007110081100911010110111101211013110141101511016110171101811019110201102111022110231102411025110261102711028110291103011031110321103311034110351103611037110381103911040110411104211043110441104511046110471104811049110501105111052110531105411055110561105711058110591106011061110621106311064110651106611067110681106911070110711107211073110741107511076110771107811079110801108111082110831108411085110861108711088110891109011091110921109311094110951109611097110981109911100111011110211103111041110511106111071110811109111101111111112111131111411115111161111711118111191112011121111221112311124111251112611127111281112911130111311113211133111341113511136111371113811139111401114111142111431114411145111461114711148111491115011151111521115311154111551115611157111581115911160111611116211163111641116511166111671116811169111701117111172111731117411175111761117711178111791118011181111821118311184111851118611187111881118911190111911119211193111941119511196111971119811199112001120111202112031120411205112061120711208112091121011211112121121311214112151121611217112181121911220112211122211223112241122511226112271122811229112301123111232112331123411235112361123711238112391124011241112421124311244112451124611247112481124911250112511125211253112541125511256112571125811259112601126111262112631126411265112661126711268112691127011271112721127311274112751127611277112781127911280112811128211283112841128511286112871128811289112901129111292112931129411295112961129711298112991130011301113021130311304113051130611307113081130911310113111131211313113141131511316113171131811319113201132111322113231132411325113261132711328113291133011331113321133311334113351133611337113381133911340113411134211343113441134511346113471134811349113501135111352113531135411355113561135711358113591136011361113621136311364113651136611367113681136911370113711137211373113741137511376113771137811379113801138111382113831138411385113861138711388113891139011391113921139311394113951139611397113981139911400114011140211403114041140511406114071140811409114101141111412114131141411415114161141711418114191142011421114221142311424114251142611427114281142911430114311143211433114341143511436114371143811439114401144111442114431144411445114461144711448114491145011451114521145311454114551145611457114581145911460114611146211463114641146511466114671146811469114701147111472114731147411475114761147711478114791148011481114821148311484114851148611487114881148911490114911149211493114941149511496114971149811499115001150111502115031150411505115061150711508115091151011511115121151311514115151151611517115181151911520115211152211523115241152511526115271152811529115301153111532115331153411535115361153711538115391154011541115421154311544115451154611547115481154911550115511155211553115541155511556115571155811559115601156111562115631156411565115661156711568115691157011571115721157311574115751157611577115781157911580115811158211583115841158511586115871158811589115901159111592115931159411595115961159711598115991160011601116021160311604116051160611607116081160911610116111161211613116141161511616116171161811619116201162111622116231162411625116261162711628116291163011631116321163311634116351163611637116381163911640116411164211643116441164511646116471164811649116501165111652116531165411655116561165711658116591166011661116621166311664116651166611667116681166911670116711167211673116741167511676116771167811679116801168111682116831168411685116861168711688116891169011691116921169311694116951169611697116981169911700117011170211703117041170511706117071170811709117101171111712117131171411715117161171711718117191172011721117221172311724117251172611727117281172911730117311173211733117341173511736117371173811739117401174111742117431174411745117461174711748117491175011751117521175311754117551175611757117581175911760117611176211763117641176511766117671176811769117701177111772117731177411775117761177711778117791178011781117821178311784117851178611787117881178911790117911179211793117941179511796117971179811799118001180111802118031180411805118061180711808118091181011811118121181311814118151181611817118181181911820118211182211823118241182511826118271182811829118301183111832118331183411835118361183711838118391184011841118421184311844118451184611847118481184911850118511185211853118541185511856118571185811859118601186111862118631186411865118661186711868118691187011871118721187311874118751187611877118781187911880118811188211883118841188511886118871188811889118901189111892118931189411895118961189711898118991190011901119021190311904119051190611907119081190911910119111191211913119141191511916119171191811919119201192111922119231192411925119261192711928119291193011931119321193311934119351193611937119381193911940119411194211943119441194511946119471194811949119501195111952119531195411955119561195711958119591196011961119621196311964119651196611967119681196911970119711197211973119741197511976119771197811979119801198111982119831198411985119861198711988119891199011991119921199311994119951199611997119981199912000120011200212003120041200512006120071200812009120101201112012120131201412015120161201712018120191202012021120221202312024120251202612027120281202912030120311203212033120341203512036120371203812039120401204112042120431204412045120461204712048120491205012051120521205312054120551205612057120581205912060120611206212063120641206512066120671206812069120701207112072120731207412075120761207712078120791208012081120821208312084120851208612087120881208912090120911209212093120941209512096120971209812099121001210112102121031210412105121061210712108121091211012111121121211312114121151211612117121181211912120121211212212123121241212512126121271212812129121301213112132121331213412135121361213712138121391214012141121421214312144121451214612147121481214912150121511215212153121541215512156121571215812159121601216112162121631216412165121661216712168121691217012171121721217312174121751217612177121781217912180121811218212183121841218512186121871218812189121901219112192121931219412195121961219712198121991220012201122021220312204122051220612207122081220912210122111221212213122141221512216122171221812219122201222112222122231222412225122261222712228122291223012231122321223312234122351223612237122381223912240122411224212243122441224512246122471224812249122501225112252122531225412255122561225712258122591226012261122621226312264122651226612267122681226912270122711227212273122741227512276122771227812279122801228112282122831228412285122861228712288122891229012291122921229312294122951229612297122981229912300123011230212303123041230512306123071230812309123101231112312123131231412315123161231712318123191232012321123221232312324123251232612327123281232912330123311233212333123341233512336123371233812339123401234112342123431234412345123461234712348123491235012351123521235312354123551235612357123581235912360123611236212363123641236512366123671236812369123701237112372123731237412375123761237712378123791238012381123821238312384123851238612387123881238912390123911239212393123941239512396123971239812399124001240112402124031240412405124061240712408124091241012411124121241312414124151241612417124181241912420124211242212423124241242512426124271242812429124301243112432124331243412435124361243712438124391244012441124421244312444124451244612447124481244912450124511245212453124541245512456124571245812459124601246112462124631246412465124661246712468124691247012471124721247312474124751247612477124781247912480124811248212483124841248512486124871248812489124901249112492124931249412495124961249712498124991250012501125021250312504125051250612507125081250912510125111251212513125141251512516125171251812519125201252112522125231252412525125261252712528125291253012531125321253312534125351253612537125381253912540125411254212543125441254512546125471254812549125501255112552125531255412555125561255712558125591256012561125621256312564125651256612567125681256912570125711257212573125741257512576125771257812579125801258112582125831258412585125861258712588125891259012591125921259312594125951259612597125981259912600126011260212603126041260512606126071260812609126101261112612126131261412615126161261712618126191262012621126221262312624126251262612627126281262912630126311263212633126341263512636126371263812639126401264112642126431264412645126461264712648126491265012651126521265312654126551265612657126581265912660126611266212663126641266512666126671266812669126701267112672126731267412675126761267712678126791268012681126821268312684126851268612687126881268912690126911269212693126941269512696126971269812699127001270112702127031270412705127061270712708127091271012711127121271312714127151271612717127181271912720127211272212723127241272512726127271272812729127301273112732127331273412735127361273712738127391274012741127421274312744127451274612747127481274912750127511275212753127541275512756127571275812759127601276112762127631276412765127661276712768127691277012771127721277312774127751277612777127781277912780127811278212783127841278512786127871278812789127901279112792127931279412795127961279712798127991280012801128021280312804128051280612807128081280912810128111281212813128141281512816128171281812819128201282112822128231282412825128261282712828128291283012831128321283312834128351283612837128381283912840128411284212843128441284512846128471284812849128501285112852128531285412855128561285712858128591286012861128621286312864128651286612867128681286912870128711287212873128741287512876128771287812879128801288112882128831288412885128861288712888128891289012891128921289312894128951289612897128981289912900129011290212903129041290512906129071290812909129101291112912129131291412915129161291712918129191292012921129221292312924129251292612927129281292912930129311293212933129341293512936129371293812939129401294112942129431294412945129461294712948129491295012951129521295312954129551295612957129581295912960129611296212963129641296512966129671296812969129701297112972129731297412975129761297712978129791298012981129821298312984129851298612987129881298912990129911299212993129941299512996129971299812999130001300113002130031300413005130061300713008130091301013011130121301313014130151301613017130181301913020130211302213023130241302513026130271302813029130301303113032130331303413035130361303713038130391304013041130421304313044130451304613047130481304913050130511305213053130541305513056130571305813059130601306113062130631306413065130661306713068130691307013071130721307313074130751307613077130781307913080130811308213083130841308513086130871308813089130901309113092130931309413095130961309713098130991310013101131021310313104131051310613107131081310913110131111311213113131141311513116131171311813119131201312113122131231312413125131261312713128131291313013131131321313313134131351313613137131381313913140131411314213143131441314513146131471314813149131501315113152131531315413155131561315713158131591316013161131621316313164131651316613167131681316913170131711317213173131741317513176131771317813179131801318113182131831318413185131861318713188131891319013191131921319313194131951319613197131981319913200132011320213203132041320513206132071320813209132101321113212132131321413215132161321713218132191322013221132221322313224132251322613227132281322913230132311323213233132341323513236132371323813239132401324113242132431324413245132461324713248132491325013251132521325313254132551325613257132581325913260132611326213263132641326513266132671326813269132701327113272132731327413275132761327713278132791328013281132821328313284132851328613287132881328913290132911329213293132941329513296132971329813299133001330113302133031330413305133061330713308133091331013311133121331313314133151331613317133181331913320133211332213323133241332513326133271332813329133301333113332133331333413335133361333713338133391334013341133421334313344133451334613347133481334913350133511335213353133541335513356133571335813359133601336113362133631336413365133661336713368133691337013371133721337313374133751337613377133781337913380133811338213383133841338513386133871338813389133901339113392133931339413395133961339713398133991340013401134021340313404134051340613407134081340913410134111341213413134141341513416134171341813419134201342113422134231342413425134261342713428134291343013431134321343313434134351343613437134381343913440134411344213443134441344513446134471344813449134501345113452134531345413455134561345713458134591346013461134621346313464134651346613467134681346913470134711347213473134741347513476134771347813479134801348113482134831348413485134861348713488134891349013491134921349313494134951349613497134981349913500135011350213503135041350513506135071350813509135101351113512135131351413515135161351713518135191352013521135221352313524135251352613527135281352913530135311353213533135341353513536135371353813539135401354113542135431354413545135461354713548135491355013551135521355313554135551355613557135581355913560135611356213563135641356513566135671356813569135701357113572135731357413575135761357713578135791358013581135821358313584135851358613587135881358913590135911359213593135941359513596135971359813599136001360113602136031360413605136061360713608136091361013611136121361313614136151361613617136181361913620136211362213623136241362513626136271362813629136301363113632136331363413635136361363713638136391364013641136421364313644136451364613647136481364913650136511365213653136541365513656136571365813659136601366113662136631366413665136661366713668136691367013671136721367313674136751367613677136781367913680136811368213683136841368513686136871368813689136901369113692136931369413695136961369713698136991370013701137021370313704137051370613707137081370913710137111371213713137141371513716137171371813719137201372113722137231372413725137261372713728137291373013731137321373313734137351373613737137381373913740137411374213743137441374513746137471374813749137501375113752137531375413755137561375713758137591376013761137621376313764137651376613767137681376913770137711377213773137741377513776137771377813779137801378113782137831378413785137861378713788137891379013791137921379313794137951379613797137981379913800138011380213803138041380513806138071380813809138101381113812138131381413815138161381713818138191382013821138221382313824138251382613827138281382913830138311383213833138341383513836138371383813839138401384113842138431384413845138461384713848138491385013851138521385313854138551385613857138581385913860138611386213863138641386513866138671386813869138701387113872138731387413875138761387713878138791388013881138821388313884138851388613887138881388913890138911389213893138941389513896138971389813899139001390113902139031390413905139061390713908139091391013911139121391313914139151391613917139181391913920139211392213923139241392513926139271392813929139301393113932139331393413935139361393713938139391394013941139421394313944139451394613947139481394913950139511395213953139541395513956139571395813959139601396113962139631396413965139661396713968139691397013971139721397313974139751397613977139781397913980139811398213983139841398513986139871398813989139901399113992139931399413995139961399713998139991400014001140021400314004140051400614007140081400914010140111401214013140141401514016140171401814019140201402114022140231402414025140261402714028140291403014031140321403314034140351403614037140381403914040140411404214043140441404514046140471404814049140501405114052140531405414055140561405714058140591406014061140621406314064140651406614067140681406914070140711407214073140741407514076140771407814079140801408114082140831408414085140861408714088140891409014091140921409314094140951409614097140981409914100141011410214103141041410514106141071410814109141101411114112141131411414115141161411714118141191412014121141221412314124141251412614127141281412914130141311413214133141341413514136141371413814139141401414114142141431414414145141461414714148141491415014151141521415314154141551415614157141581415914160141611416214163141641416514166141671416814169141701417114172141731417414175141761417714178141791418014181141821418314184141851418614187141881418914190141911419214193141941419514196141971419814199142001420114202142031420414205142061420714208142091421014211142121421314214142151421614217142181421914220142211422214223142241422514226142271422814229142301423114232142331423414235142361423714238142391424014241142421424314244142451424614247142481424914250142511425214253142541425514256142571425814259142601426114262142631426414265142661426714268142691427014271142721427314274142751427614277142781427914280142811428214283142841428514286142871428814289142901429114292142931429414295142961429714298142991430014301143021430314304143051430614307143081430914310143111431214313143141431514316143171431814319143201432114322143231432414325143261432714328143291433014331143321433314334143351433614337143381433914340143411434214343143441434514346143471434814349143501435114352143531435414355143561435714358143591436014361143621436314364143651436614367143681436914370143711437214373143741437514376143771437814379143801438114382143831438414385143861438714388143891439014391143921439314394143951439614397143981439914400144011440214403144041440514406144071440814409144101441114412144131441414415144161441714418144191442014421144221442314424144251442614427144281442914430144311443214433144341443514436144371443814439144401444114442144431444414445144461444714448144491445014451144521445314454144551445614457144581445914460144611446214463144641446514466144671446814469144701447114472144731447414475144761447714478144791448014481144821448314484144851448614487144881448914490144911449214493144941449514496144971449814499145001450114502145031450414505145061450714508145091451014511145121451314514145151451614517145181451914520145211452214523145241452514526145271452814529145301453114532145331453414535145361453714538145391454014541145421454314544145451454614547145481454914550145511455214553145541455514556145571455814559145601456114562145631456414565145661456714568145691457014571145721457314574145751457614577145781457914580145811458214583145841458514586145871458814589145901459114592145931459414595145961459714598145991460014601146021460314604146051460614607146081460914610146111461214613146141461514616146171461814619146201462114622146231462414625146261462714628146291463014631146321463314634146351463614637146381463914640146411464214643146441464514646146471464814649146501465114652146531465414655146561465714658146591466014661146621466314664146651466614667146681466914670146711467214673146741467514676146771467814679146801468114682146831468414685146861468714688146891469014691146921469314694146951469614697146981469914700147011470214703147041470514706147071470814709147101471114712147131471414715147161471714718147191472014721147221472314724147251472614727147281472914730147311473214733147341473514736147371473814739147401474114742147431474414745147461474714748147491475014751147521475314754147551475614757147581475914760147611476214763147641476514766147671476814769147701477114772147731477414775147761477714778147791478014781147821478314784147851478614787147881478914790147911479214793147941479514796147971479814799148001480114802148031480414805148061480714808148091481014811148121481314814148151481614817148181481914820148211482214823148241482514826148271482814829148301483114832148331483414835148361483714838148391484014841148421484314844148451484614847148481484914850148511485214853148541485514856148571485814859148601486114862148631486414865148661486714868148691487014871148721487314874148751487614877148781487914880148811488214883148841488514886148871488814889148901489114892148931489414895148961489714898148991490014901149021490314904149051490614907149081490914910149111491214913149141491514916149171491814919149201492114922149231492414925149261492714928149291493014931149321493314934149351493614937149381493914940149411494214943149441494514946149471494814949149501495114952149531495414955149561495714958149591496014961149621496314964149651496614967149681496914970149711497214973149741497514976149771497814979149801498114982149831498414985149861498714988149891499014991149921499314994149951499614997149981499915000150011500215003150041500515006150071500815009150101501115012150131501415015150161501715018150191502015021150221502315024150251502615027150281502915030150311503215033150341503515036150371503815039150401504115042150431504415045150461504715048150491505015051150521505315054150551505615057150581505915060150611506215063150641506515066150671506815069150701507115072150731507415075150761507715078150791508015081150821508315084150851508615087150881508915090150911509215093150941509515096150971509815099151001510115102151031510415105151061510715108151091511015111151121511315114151151511615117151181511915120151211512215123151241512515126151271512815129151301513115132151331513415135151361513715138151391514015141151421514315144151451514615147151481514915150151511515215153151541515515156151571515815159151601516115162151631516415165151661516715168151691517015171151721517315174151751517615177151781517915180151811518215183151841518515186151871518815189151901519115192151931519415195151961519715198151991520015201152021520315204152051520615207152081520915210152111521215213152141521515216152171521815219152201522115222152231522415225152261522715228152291523015231152321523315234152351523615237152381523915240152411524215243152441524515246152471524815249152501525115252152531525415255152561525715258152591526015261152621526315264152651526615267152681526915270152711527215273152741527515276152771527815279152801528115282152831528415285152861528715288152891529015291152921529315294152951529615297152981529915300153011530215303153041530515306153071530815309153101531115312153131531415315153161531715318153191532015321153221532315324153251532615327153281532915330153311533215333153341533515336153371533815339153401534115342153431534415345153461534715348153491535015351153521535315354153551535615357153581535915360153611536215363153641536515366153671536815369153701537115372153731537415375153761537715378153791538015381153821538315384153851538615387153881538915390153911539215393153941539515396153971539815399154001540115402154031540415405154061540715408154091541015411154121541315414154151541615417154181541915420154211542215423154241542515426154271542815429154301543115432154331543415435154361543715438154391544015441154421544315444154451544615447154481544915450154511545215453154541545515456154571545815459154601546115462154631546415465154661546715468154691547015471154721547315474154751547615477154781547915480154811548215483154841548515486154871548815489154901549115492154931549415495154961549715498154991550015501155021550315504155051550615507155081550915510155111551215513155141551515516155171551815519155201552115522155231552415525155261552715528155291553015531155321553315534155351553615537155381553915540155411554215543155441554515546155471554815549155501555115552155531555415555155561555715558155591556015561155621556315564155651556615567155681556915570155711557215573155741557515576155771557815579155801558115582155831558415585155861558715588155891559015591155921559315594155951559615597155981559915600156011560215603156041560515606156071560815609156101561115612156131561415615156161561715618156191562015621156221562315624156251562615627156281562915630156311563215633156341563515636156371563815639156401564115642156431564415645156461564715648156491565015651156521565315654156551565615657156581565915660156611566215663156641566515666156671566815669156701567115672156731567415675156761567715678156791568015681156821568315684156851568615687156881568915690156911569215693156941569515696156971569815699157001570115702157031570415705157061570715708157091571015711157121571315714157151571615717157181571915720157211572215723157241572515726157271572815729157301573115732157331573415735157361573715738157391574015741157421574315744157451574615747157481574915750157511575215753157541575515756157571575815759157601576115762157631576415765157661576715768157691577015771157721577315774157751577615777157781577915780157811578215783157841578515786157871578815789157901579115792157931579415795157961579715798157991580015801158021580315804158051580615807158081580915810158111581215813158141581515816158171581815819158201582115822158231582415825158261582715828158291583015831158321583315834158351583615837158381583915840158411584215843158441584515846158471584815849158501585115852158531585415855158561585715858158591586015861158621586315864158651586615867158681586915870158711587215873158741587515876158771587815879158801588115882158831588415885158861588715888158891589015891158921589315894158951589615897158981589915900159011590215903159041590515906159071590815909159101591115912159131591415915159161591715918159191592015921159221592315924159251592615927159281592915930159311593215933159341593515936159371593815939159401594115942159431594415945159461594715948159491595015951159521595315954159551595615957159581595915960159611596215963159641596515966159671596815969159701597115972159731597415975159761597715978159791598015981159821598315984159851598615987159881598915990159911599215993159941599515996159971599815999160001600116002160031600416005160061600716008160091601016011160121601316014160151601616017160181601916020160211602216023160241602516026160271602816029160301603116032160331603416035160361603716038160391604016041160421604316044160451604616047160481604916050160511605216053160541605516056160571605816059160601606116062160631606416065160661606716068160691607016071160721607316074160751607616077160781607916080160811608216083160841608516086160871608816089160901609116092160931609416095160961609716098160991610016101161021610316104161051610616107161081610916110161111611216113161141611516116161171611816119161201612116122161231612416125161261612716128161291613016131161321613316134161351613616137161381613916140161411614216143161441614516146161471614816149161501615116152161531615416155161561615716158161591616016161161621616316164161651616616167161681616916170161711617216173161741617516176161771617816179161801618116182161831618416185161861618716188161891619016191161921619316194161951619616197161981619916200162011620216203162041620516206162071620816209162101621116212162131621416215162161621716218162191622016221162221622316224162251622616227162281622916230162311623216233162341623516236162371623816239162401624116242162431624416245162461624716248162491625016251162521625316254162551625616257162581625916260162611626216263162641626516266162671626816269162701627116272162731627416275162761627716278162791628016281162821628316284162851628616287162881628916290162911629216293162941629516296162971629816299163001630116302163031630416305163061630716308163091631016311163121631316314163151631616317163181631916320163211632216323163241632516326163271632816329163301633116332163331633416335163361633716338163391634016341163421634316344163451634616347163481634916350163511635216353163541635516356163571635816359163601636116362163631636416365163661636716368163691637016371163721637316374163751637616377163781637916380163811638216383163841638516386163871638816389163901639116392163931639416395163961639716398163991640016401164021640316404164051640616407164081640916410164111641216413164141641516416164171641816419164201642116422164231642416425164261642716428164291643016431164321643316434164351643616437164381643916440164411644216443164441644516446164471644816449164501645116452164531645416455164561645716458164591646016461164621646316464164651646616467164681646916470164711647216473164741647516476164771647816479164801648116482164831648416485164861648716488164891649016491164921649316494164951649616497164981649916500165011650216503165041650516506165071650816509165101651116512165131651416515165161651716518165191652016521165221652316524165251652616527165281652916530165311653216533165341653516536165371653816539165401654116542165431654416545165461654716548165491655016551165521655316554165551655616557165581655916560165611656216563165641656516566165671656816569165701657116572165731657416575165761657716578165791658016581165821658316584165851658616587165881658916590165911659216593165941659516596165971659816599166001660116602166031660416605166061660716608166091661016611166121661316614166151661616617166181661916620166211662216623166241662516626166271662816629166301663116632166331663416635166361663716638166391664016641166421664316644166451664616647166481664916650166511665216653166541665516656166571665816659166601666116662166631666416665166661666716668166691667016671166721667316674166751667616677166781667916680166811668216683166841668516686166871668816689166901669116692166931669416695166961669716698166991670016701167021670316704167051670616707167081670916710167111671216713167141671516716167171671816719167201672116722167231672416725167261672716728167291673016731167321673316734167351673616737167381673916740167411674216743167441674516746167471674816749167501675116752167531675416755167561675716758167591676016761167621676316764167651676616767167681676916770167711677216773167741677516776167771677816779167801678116782167831678416785167861678716788167891679016791167921679316794167951679616797167981679916800168011680216803168041680516806168071680816809168101681116812168131681416815168161681716818168191682016821168221682316824168251682616827168281682916830168311683216833168341683516836168371683816839168401684116842168431684416845168461684716848168491685016851168521685316854168551685616857168581685916860168611686216863168641686516866168671686816869168701687116872168731687416875168761687716878168791688016881168821688316884168851688616887168881688916890168911689216893168941689516896168971689816899169001690116902169031690416905169061690716908169091691016911169121691316914169151691616917169181691916920169211692216923169241692516926169271692816929169301693116932169331693416935169361693716938169391694016941169421694316944169451694616947169481694916950169511695216953169541695516956169571695816959169601696116962169631696416965169661696716968169691697016971169721697316974169751697616977169781697916980169811698216983169841698516986169871698816989169901699116992169931699416995169961699716998169991700017001170021700317004170051700617007170081700917010170111701217013170141701517016170171701817019170201702117022170231702417025170261702717028170291703017031170321703317034170351703617037170381703917040170411704217043170441704517046170471704817049170501705117052170531705417055170561705717058170591706017061170621706317064170651706617067170681706917070170711707217073170741707517076170771707817079170801708117082170831708417085170861708717088170891709017091170921709317094170951709617097170981709917100171011710217103171041710517106171071710817109171101711117112171131711417115171161711717118171191712017121171221712317124171251712617127171281712917130171311713217133171341713517136171371713817139171401714117142171431714417145171461714717148171491715017151171521715317154171551715617157171581715917160171611716217163171641716517166171671716817169171701717117172171731717417175171761717717178171791718017181171821718317184171851718617187171881718917190171911719217193171941719517196171971719817199172001720117202172031720417205172061720717208172091721017211172121721317214172151721617217172181721917220172211722217223172241722517226172271722817229172301723117232172331723417235172361723717238172391724017241172421724317244172451724617247172481724917250172511725217253172541725517256172571725817259172601726117262172631726417265172661726717268172691727017271172721727317274172751727617277172781727917280172811728217283172841728517286172871728817289172901729117292172931729417295172961729717298172991730017301173021730317304173051730617307173081730917310173111731217313173141731517316173171731817319173201732117322173231732417325173261732717328173291733017331173321733317334173351733617337173381733917340173411734217343173441734517346173471734817349173501735117352173531735417355173561735717358173591736017361173621736317364173651736617367173681736917370173711737217373173741737517376173771737817379173801738117382173831738417385173861738717388173891739017391173921739317394173951739617397173981739917400174011740217403174041740517406174071740817409174101741117412174131741417415174161741717418174191742017421174221742317424174251742617427174281742917430174311743217433174341743517436174371743817439174401744117442174431744417445174461744717448174491745017451174521745317454174551745617457174581745917460174611746217463174641746517466174671746817469174701747117472174731747417475174761747717478174791748017481174821748317484174851748617487174881748917490174911749217493174941749517496174971749817499175001750117502175031750417505175061750717508175091751017511175121751317514175151751617517175181751917520175211752217523175241752517526175271752817529175301753117532175331753417535175361753717538175391754017541175421754317544175451754617547175481754917550175511755217553175541755517556175571755817559175601756117562175631756417565175661756717568175691757017571175721757317574175751757617577175781757917580175811758217583175841758517586175871758817589175901759117592175931759417595175961759717598175991760017601176021760317604176051760617607176081760917610176111761217613176141761517616176171761817619176201762117622176231762417625176261762717628176291763017631176321763317634176351763617637176381763917640176411764217643176441764517646176471764817649176501765117652176531765417655176561765717658176591766017661176621766317664176651766617667176681766917670176711767217673176741767517676176771767817679176801768117682176831768417685176861768717688176891769017691176921769317694176951769617697176981769917700177011770217703177041770517706177071770817709177101771117712177131771417715177161771717718177191772017721177221772317724177251772617727177281772917730177311773217733177341773517736177371773817739177401774117742177431774417745177461774717748177491775017751177521775317754177551775617757177581775917760177611776217763177641776517766177671776817769177701777117772177731777417775177761777717778177791778017781177821778317784177851778617787177881778917790177911779217793177941779517796177971779817799178001780117802178031780417805178061780717808178091781017811178121781317814178151781617817178181781917820178211782217823178241782517826178271782817829178301783117832178331783417835178361783717838178391784017841178421784317844178451784617847178481784917850178511785217853178541785517856178571785817859178601786117862178631786417865178661786717868178691787017871178721787317874178751787617877178781787917880178811788217883178841788517886178871788817889178901789117892178931789417895178961789717898178991790017901179021790317904179051790617907179081790917910179111791217913179141791517916179171791817919179201792117922179231792417925179261792717928179291793017931179321793317934179351793617937179381793917940179411794217943179441794517946179471794817949179501795117952179531795417955179561795717958179591796017961179621796317964179651796617967179681796917970179711797217973179741797517976179771797817979179801798117982179831798417985179861798717988179891799017991179921799317994179951799617997179981799918000180011800218003180041800518006180071800818009180101801118012180131801418015180161801718018180191802018021180221802318024180251802618027180281802918030180311803218033180341803518036180371803818039180401804118042180431804418045180461804718048180491805018051180521805318054180551805618057180581805918060180611806218063180641806518066180671806818069180701807118072180731807418075180761807718078180791808018081180821808318084180851808618087180881808918090180911809218093180941809518096180971809818099181001810118102181031810418105181061810718108181091811018111181121811318114181151811618117181181811918120181211812218123181241812518126181271812818129181301813118132181331813418135181361813718138181391814018141181421814318144181451814618147181481814918150181511815218153181541815518156181571815818159181601816118162181631816418165181661816718168181691817018171181721817318174181751817618177181781817918180181811818218183181841818518186181871818818189181901819118192181931819418195181961819718198181991820018201182021820318204182051820618207182081820918210182111821218213182141821518216182171821818219182201822118222182231822418225182261822718228182291823018231182321823318234182351823618237182381823918240182411824218243182441824518246182471824818249182501825118252182531825418255182561825718258182591826018261182621826318264182651826618267182681826918270182711827218273182741827518276182771827818279182801828118282182831828418285182861828718288182891829018291182921829318294182951829618297182981829918300183011830218303183041830518306183071830818309183101831118312183131831418315183161831718318183191832018321183221832318324183251832618327183281832918330183311833218333183341833518336183371833818339183401834118342183431834418345183461834718348183491835018351183521835318354183551835618357183581835918360183611836218363183641836518366183671836818369183701837118372183731837418375183761837718378183791838018381183821838318384183851838618387183881838918390183911839218393183941839518396183971839818399184001840118402184031840418405184061840718408184091841018411184121841318414184151841618417184181841918420184211842218423184241842518426184271842818429184301843118432184331843418435184361843718438184391844018441184421844318444184451844618447184481844918450184511845218453184541845518456184571845818459184601846118462184631846418465184661846718468184691847018471184721847318474184751847618477184781847918480184811848218483184841848518486184871848818489184901849118492184931849418495184961849718498184991850018501185021850318504185051850618507185081850918510185111851218513185141851518516185171851818519185201852118522185231852418525185261852718528185291853018531185321853318534185351853618537185381853918540185411854218543185441854518546185471854818549185501855118552185531855418555185561855718558185591856018561185621856318564185651856618567185681856918570185711857218573185741857518576185771857818579185801858118582185831858418585185861858718588185891859018591185921859318594185951859618597185981859918600186011860218603186041860518606186071860818609186101861118612186131861418615186161861718618186191862018621186221862318624186251862618627186281862918630186311863218633186341863518636186371863818639186401864118642186431864418645186461864718648186491865018651186521865318654186551865618657186581865918660186611866218663186641866518666186671866818669186701867118672186731867418675186761867718678186791868018681186821868318684186851868618687186881868918690186911869218693186941869518696186971869818699187001870118702187031870418705187061870718708187091871018711187121871318714187151871618717187181871918720187211872218723187241872518726187271872818729187301873118732187331873418735187361873718738187391874018741187421874318744187451874618747187481874918750187511875218753187541875518756187571875818759187601876118762187631876418765187661876718768187691877018771187721877318774187751877618777187781877918780187811878218783187841878518786187871878818789187901879118792187931879418795187961879718798187991880018801188021880318804188051880618807188081880918810188111881218813188141881518816188171881818819188201882118822188231882418825188261882718828188291883018831188321883318834188351883618837188381883918840188411884218843188441884518846188471884818849188501885118852188531885418855188561885718858188591886018861188621886318864188651886618867188681886918870188711887218873188741887518876188771887818879188801888118882188831888418885188861888718888188891889018891188921889318894188951889618897188981889918900189011890218903189041890518906189071890818909189101891118912189131891418915189161891718918189191892018921189221892318924189251892618927189281892918930189311893218933189341893518936189371893818939189401894118942189431894418945189461894718948189491895018951189521895318954189551895618957189581895918960189611896218963189641896518966189671896818969189701897118972189731897418975189761897718978189791898018981189821898318984189851898618987189881898918990189911899218993189941899518996189971899818999190001900119002190031900419005190061900719008190091901019011190121901319014190151901619017190181901919020190211902219023190241902519026190271902819029190301903119032190331903419035190361903719038190391904019041190421904319044190451904619047190481904919050190511905219053190541905519056190571905819059190601906119062190631906419065190661906719068190691907019071190721907319074190751907619077190781907919080190811908219083190841908519086190871908819089190901909119092190931909419095190961909719098190991910019101191021910319104191051910619107191081910919110191111911219113191141911519116191171911819119191201912119122191231912419125191261912719128191291913019131191321913319134191351913619137191381913919140191411914219143191441914519146191471914819149191501915119152191531915419155191561915719158191591916019161191621916319164191651916619167191681916919170191711917219173191741917519176191771917819179191801918119182191831918419185191861918719188191891919019191191921919319194191951919619197191981919919200192011920219203192041920519206192071920819209192101921119212192131921419215192161921719218192191922019221192221922319224192251922619227192281922919230192311923219233192341923519236192371923819239192401924119242192431924419245192461924719248192491925019251192521925319254192551925619257192581925919260192611926219263192641926519266192671926819269192701927119272192731927419275192761927719278192791928019281192821928319284192851928619287192881928919290192911929219293192941929519296192971929819299193001930119302193031930419305193061930719308193091931019311193121931319314193151931619317193181931919320193211932219323193241932519326193271932819329193301933119332193331933419335193361933719338193391934019341193421934319344193451934619347193481934919350193511935219353193541935519356193571935819359193601936119362193631936419365193661936719368193691937019371193721937319374193751937619377193781937919380193811938219383193841938519386193871938819389193901939119392193931939419395193961939719398193991940019401194021940319404194051940619407194081940919410194111941219413194141941519416194171941819419194201942119422194231942419425194261942719428194291943019431194321943319434194351943619437194381943919440194411944219443194441944519446194471944819449194501945119452194531945419455194561945719458194591946019461194621946319464194651946619467194681946919470194711947219473194741947519476194771947819479194801948119482194831948419485194861948719488194891949019491194921949319494194951949619497194981949919500195011950219503195041950519506195071950819509195101951119512195131951419515195161951719518195191952019521195221952319524195251952619527195281952919530195311953219533195341953519536195371953819539195401954119542195431954419545195461954719548195491955019551195521955319554195551955619557195581955919560195611956219563195641956519566195671956819569195701957119572195731957419575195761957719578195791958019581195821958319584195851958619587195881958919590195911959219593195941959519596195971959819599196001960119602196031960419605196061960719608196091961019611196121961319614196151961619617196181961919620196211962219623196241962519626196271962819629196301963119632196331963419635196361963719638196391964019641196421964319644196451964619647196481964919650196511965219653196541965519656196571965819659196601966119662196631966419665196661966719668196691967019671196721967319674196751967619677196781967919680196811968219683196841968519686196871968819689196901969119692196931969419695196961969719698196991970019701197021970319704197051970619707197081970919710197111971219713197141971519716197171971819719197201972119722197231972419725197261972719728197291973019731197321973319734197351973619737197381973919740197411974219743197441974519746197471974819749197501975119752197531975419755197561975719758197591976019761197621976319764197651976619767197681976919770197711977219773197741977519776197771977819779197801978119782197831978419785197861978719788197891979019791197921979319794197951979619797197981979919800198011980219803198041980519806198071980819809198101981119812198131981419815198161981719818198191982019821198221982319824198251982619827198281982919830198311983219833198341983519836198371983819839198401984119842198431984419845198461984719848198491985019851198521985319854198551985619857198581985919860198611986219863198641986519866198671986819869198701987119872198731987419875198761987719878198791988019881198821988319884198851988619887198881988919890198911989219893198941989519896198971989819899199001990119902199031990419905199061990719908199091991019911199121991319914199151991619917199181991919920199211992219923199241992519926199271992819929199301993119932199331993419935199361993719938199391994019941199421994319944199451994619947199481994919950199511995219953199541995519956199571995819959199601996119962199631996419965199661996719968199691997019971199721997319974199751997619977199781997919980199811998219983199841998519986199871998819989199901999119992199931999419995199961999719998199992000020001200022000320004200052000620007200082000920010200112001220013200142001520016200172001820019200202002120022200232002420025200262002720028200292003020031200322003320034200352003620037200382003920040200412004220043200442004520046200472004820049200502005120052200532005420055200562005720058200592006020061200622006320064200652006620067200682006920070200712007220073200742007520076200772007820079200802008120082200832008420085200862008720088200892009020091200922009320094200952009620097200982009920100201012010220103201042010520106201072010820109201102011120112201132011420115201162011720118201192012020121201222012320124201252012620127201282012920130201312013220133201342013520136201372013820139201402014120142201432014420145201462014720148201492015020151201522015320154201552015620157201582015920160201612016220163201642016520166201672016820169201702017120172201732017420175201762017720178201792018020181201822018320184201852018620187201882018920190201912019220193201942019520196201972019820199202002020120202202032020420205202062020720208202092021020211202122021320214202152021620217202182021920220202212022220223202242022520226202272022820229202302023120232202332023420235202362023720238202392024020241202422024320244202452024620247202482024920250202512025220253202542025520256202572025820259202602026120262202632026420265202662026720268202692027020271202722027320274202752027620277202782027920280202812028220283202842028520286202872028820289202902029120292202932029420295202962029720298202992030020301203022030320304203052030620307203082030920310203112031220313203142031520316203172031820319203202032120322203232032420325203262032720328203292033020331203322033320334203352033620337203382033920340203412034220343203442034520346203472034820349203502035120352203532035420355203562035720358203592036020361203622036320364203652036620367203682036920370203712037220373203742037520376203772037820379203802038120382203832038420385203862038720388203892039020391203922039320394203952039620397203982039920400204012040220403204042040520406204072040820409204102041120412204132041420415204162041720418204192042020421204222042320424204252042620427204282042920430204312043220433204342043520436204372043820439204402044120442204432044420445204462044720448204492045020451204522045320454204552045620457204582045920460204612046220463204642046520466204672046820469204702047120472204732047420475204762047720478204792048020481204822048320484204852048620487204882048920490204912049220493204942049520496204972049820499205002050120502205032050420505205062050720508205092051020511205122051320514205152051620517205182051920520205212052220523205242052520526205272052820529205302053120532205332053420535205362053720538205392054020541205422054320544205452054620547205482054920550205512055220553205542055520556205572055820559205602056120562205632056420565205662056720568205692057020571205722057320574205752057620577205782057920580205812058220583205842058520586205872058820589205902059120592205932059420595205962059720598205992060020601206022060320604206052060620607206082060920610206112061220613206142061520616206172061820619206202062120622206232062420625206262062720628206292063020631206322063320634206352063620637206382063920640206412064220643206442064520646206472064820649206502065120652206532065420655206562065720658206592066020661206622066320664206652066620667206682066920670206712067220673206742067520676206772067820679206802068120682206832068420685206862068720688206892069020691206922069320694206952069620697206982069920700207012070220703207042070520706207072070820709207102071120712207132071420715207162071720718207192072020721207222072320724207252072620727207282072920730207312073220733207342073520736207372073820739207402074120742207432074420745207462074720748207492075020751207522075320754207552075620757207582075920760207612076220763207642076520766207672076820769207702077120772207732077420775207762077720778207792078020781207822078320784207852078620787207882078920790207912079220793207942079520796207972079820799208002080120802208032080420805208062080720808208092081020811208122081320814208152081620817208182081920820208212082220823208242082520826208272082820829208302083120832208332083420835208362083720838208392084020841208422084320844208452084620847208482084920850208512085220853208542085520856208572085820859208602086120862208632086420865208662086720868208692087020871208722087320874208752087620877208782087920880208812088220883208842088520886208872088820889208902089120892208932089420895208962089720898208992090020901209022090320904209052090620907209082090920910209112091220913209142091520916209172091820919209202092120922209232092420925209262092720928209292093020931209322093320934209352093620937209382093920940209412094220943209442094520946209472094820949209502095120952209532095420955209562095720958209592096020961209622096320964209652096620967209682096920970209712097220973209742097520976209772097820979209802098120982209832098420985209862098720988209892099020991209922099320994209952099620997209982099921000210012100221003210042100521006210072100821009210102101121012210132101421015210162101721018210192102021021210222102321024210252102621027210282102921030210312103221033210342103521036210372103821039210402104121042210432104421045210462104721048210492105021051210522105321054210552105621057210582105921060210612106221063210642106521066210672106821069210702107121072210732107421075210762107721078210792108021081210822108321084210852108621087210882108921090210912109221093210942109521096210972109821099211002110121102211032110421105211062110721108211092111021111211122111321114211152111621117211182111921120211212112221123211242112521126211272112821129211302113121132211332113421135211362113721138211392114021141211422114321144211452114621147211482114921150211512115221153211542115521156211572115821159211602116121162211632116421165211662116721168211692117021171211722117321174211752117621177211782117921180211812118221183211842118521186211872118821189211902119121192211932119421195211962119721198211992120021201212022120321204212052120621207212082120921210212112121221213212142121521216212172121821219212202122121222212232122421225212262122721228212292123021231212322123321234212352123621237212382123921240212412124221243212442124521246212472124821249212502125121252212532125421255212562125721258212592126021261212622126321264212652126621267212682126921270212712127221273212742127521276212772127821279212802128121282212832128421285212862128721288212892129021291212922129321294212952129621297212982129921300213012130221303213042130521306213072130821309213102131121312213132131421315213162131721318213192132021321213222132321324213252132621327213282132921330213312133221333213342133521336213372133821339213402134121342213432134421345213462134721348213492135021351213522135321354213552135621357213582135921360213612136221363213642136521366213672136821369213702137121372213732137421375213762137721378213792138021381213822138321384213852138621387213882138921390213912139221393213942139521396213972139821399214002140121402214032140421405214062140721408214092141021411214122141321414214152141621417214182141921420214212142221423214242142521426214272142821429214302143121432214332143421435214362143721438214392144021441214422144321444214452144621447214482144921450214512145221453214542145521456214572145821459214602146121462214632146421465214662146721468214692147021471214722147321474214752147621477214782147921480214812148221483214842148521486214872148821489214902149121492214932149421495214962149721498214992150021501215022150321504215052150621507215082150921510215112151221513215142151521516215172151821519215202152121522215232152421525215262152721528215292153021531215322153321534215352153621537215382153921540215412154221543215442154521546215472154821549215502155121552215532155421555215562155721558215592156021561215622156321564215652156621567215682156921570215712157221573215742157521576215772157821579215802158121582215832158421585215862158721588215892159021591215922159321594215952159621597215982159921600216012160221603216042160521606216072160821609216102161121612216132161421615216162161721618216192162021621216222162321624216252162621627216282162921630216312163221633216342163521636216372163821639216402164121642216432164421645216462164721648216492165021651216522165321654216552165621657216582165921660216612166221663216642166521666216672166821669216702167121672216732167421675216762167721678216792168021681216822168321684216852168621687216882168921690216912169221693216942169521696216972169821699217002170121702217032170421705217062170721708217092171021711217122171321714217152171621717217182171921720217212172221723217242172521726217272172821729217302173121732217332173421735217362173721738217392174021741217422174321744217452174621747217482174921750217512175221753217542175521756217572175821759217602176121762217632176421765217662176721768217692177021771217722177321774217752177621777217782177921780217812178221783217842178521786217872178821789217902179121792217932179421795217962179721798217992180021801218022180321804218052180621807218082180921810218112181221813218142181521816218172181821819218202182121822218232182421825218262182721828218292183021831218322183321834218352183621837218382183921840218412184221843218442184521846218472184821849218502185121852218532185421855218562185721858218592186021861218622186321864218652186621867218682186921870218712187221873218742187521876218772187821879218802188121882218832188421885218862188721888218892189021891218922189321894218952189621897218982189921900219012190221903219042190521906219072190821909219102191121912219132191421915219162191721918219192192021921219222192321924219252192621927219282192921930219312193221933219342193521936219372193821939219402194121942219432194421945219462194721948219492195021951219522195321954219552195621957219582195921960219612196221963219642196521966219672196821969219702197121972219732197421975219762197721978219792198021981219822198321984219852198621987219882198921990219912199221993219942199521996219972199821999220002200122002220032200422005220062200722008220092201022011220122201322014220152201622017220182201922020220212202222023220242202522026220272202822029220302203122032220332203422035220362203722038220392204022041220422204322044220452204622047220482204922050220512205222053220542205522056220572205822059220602206122062220632206422065220662206722068220692207022071220722207322074220752207622077220782207922080220812208222083220842208522086220872208822089220902209122092220932209422095220962209722098220992210022101221022210322104221052210622107221082210922110221112211222113221142211522116221172211822119221202212122122221232212422125221262212722128221292213022131221322213322134221352213622137221382213922140221412214222143221442214522146221472214822149221502215122152221532215422155221562215722158221592216022161221622216322164221652216622167221682216922170221712217222173221742217522176221772217822179221802218122182221832218422185221862218722188221892219022191221922219322194221952219622197221982219922200222012220222203222042220522206222072220822209222102221122212222132221422215222162221722218222192222022221222222222322224222252222622227222282222922230222312223222233222342223522236222372223822239222402224122242222432224422245222462224722248222492225022251222522225322254222552225622257222582225922260222612226222263222642226522266222672226822269222702227122272222732227422275222762227722278222792228022281222822228322284222852228622287222882228922290222912229222293222942229522296222972229822299223002230122302223032230422305223062230722308223092231022311223122231322314223152231622317223182231922320223212232222323223242232522326223272232822329223302233122332223332233422335223362233722338223392234022341223422234322344223452234622347223482234922350223512235222353223542235522356223572235822359223602236122362223632236422365223662236722368223692237022371223722237322374223752237622377223782237922380223812238222383223842238522386223872238822389223902239122392223932239422395223962239722398223992240022401224022240322404224052240622407224082240922410224112241222413224142241522416224172241822419224202242122422224232242422425224262242722428224292243022431224322243322434224352243622437224382243922440224412244222443224442244522446224472244822449224502245122452224532245422455224562245722458224592246022461224622246322464224652246622467224682246922470224712247222473224742247522476224772247822479224802248122482224832248422485224862248722488224892249022491224922249322494224952249622497224982249922500225012250222503225042250522506225072250822509225102251122512225132251422515225162251722518225192252022521225222252322524225252252622527225282252922530225312253222533225342253522536225372253822539225402254122542225432254422545225462254722548225492255022551225522255322554225552255622557225582255922560225612256222563225642256522566225672256822569225702257122572225732257422575225762257722578225792258022581225822258322584225852258622587225882258922590225912259222593225942259522596225972259822599226002260122602226032260422605226062260722608226092261022611226122261322614226152261622617226182261922620226212262222623226242262522626226272262822629226302263122632226332263422635226362263722638226392264022641226422264322644226452264622647226482264922650226512265222653226542265522656226572265822659226602266122662226632266422665226662266722668226692267022671226722267322674226752267622677226782267922680226812268222683226842268522686226872268822689226902269122692226932269422695226962269722698226992270022701227022270322704227052270622707227082270922710227112271222713227142271522716227172271822719227202272122722227232272422725227262272722728227292273022731227322273322734227352273622737227382273922740227412274222743227442274522746227472274822749227502275122752227532275422755227562275722758227592276022761227622276322764227652276622767227682276922770227712277222773227742277522776227772277822779227802278122782227832278422785227862278722788227892279022791227922279322794227952279622797227982279922800228012280222803228042280522806228072280822809228102281122812228132281422815228162281722818228192282022821228222282322824228252282622827228282282922830228312283222833228342283522836228372283822839228402284122842228432284422845228462284722848228492285022851228522285322854228552285622857228582285922860228612286222863228642286522866228672286822869228702287122872228732287422875228762287722878228792288022881228822288322884228852288622887228882288922890228912289222893228942289522896228972289822899229002290122902229032290422905229062290722908229092291022911229122291322914229152291622917229182291922920229212292222923229242292522926229272292822929229302293122932229332293422935229362293722938229392294022941229422294322944229452294622947229482294922950229512295222953229542295522956229572295822959229602296122962229632296422965229662296722968229692297022971229722297322974229752297622977229782297922980229812298222983229842298522986229872298822989229902299122992229932299422995229962299722998229992300023001230022300323004230052300623007230082300923010230112301223013230142301523016230172301823019230202302123022230232302423025230262302723028230292303023031230322303323034230352303623037230382303923040230412304223043230442304523046230472304823049230502305123052230532305423055230562305723058230592306023061230622306323064230652306623067230682306923070230712307223073230742307523076230772307823079230802308123082230832308423085230862308723088230892309023091230922309323094230952309623097230982309923100231012310223103231042310523106231072310823109231102311123112231132311423115231162311723118231192312023121231222312323124231252312623127231282312923130231312313223133231342313523136231372313823139231402314123142231432314423145231462314723148231492315023151231522315323154231552315623157231582315923160231612316223163231642316523166231672316823169231702317123172231732317423175231762317723178231792318023181231822318323184231852318623187231882318923190231912319223193231942319523196231972319823199232002320123202232032320423205232062320723208232092321023211232122321323214232152321623217232182321923220232212322223223232242322523226232272322823229232302323123232232332323423235232362323723238232392324023241232422324323244232452324623247232482324923250232512325223253232542325523256232572325823259232602326123262232632326423265232662326723268232692327023271232722327323274232752327623277232782327923280232812328223283232842328523286232872328823289232902329123292232932329423295232962329723298232992330023301233022330323304233052330623307233082330923310233112331223313233142331523316233172331823319233202332123322233232332423325233262332723328233292333023331233322333323334233352333623337233382333923340233412334223343233442334523346233472334823349233502335123352233532335423355233562335723358233592336023361233622336323364233652336623367233682336923370233712337223373233742337523376233772337823379233802338123382233832338423385233862338723388233892339023391233922339323394233952339623397233982339923400234012340223403234042340523406234072340823409234102341123412234132341423415234162341723418234192342023421234222342323424234252342623427234282342923430234312343223433234342343523436234372343823439234402344123442234432344423445234462344723448234492345023451234522345323454234552345623457234582345923460234612346223463234642346523466234672346823469234702347123472234732347423475234762347723478234792348023481234822348323484234852348623487234882348923490234912349223493234942349523496234972349823499235002350123502235032350423505235062350723508235092351023511235122351323514235152351623517235182351923520235212352223523235242352523526235272352823529235302353123532235332353423535235362353723538235392354023541235422354323544235452354623547235482354923550235512355223553235542355523556235572355823559235602356123562235632356423565235662356723568235692357023571235722357323574235752357623577235782357923580235812358223583235842358523586235872358823589235902359123592235932359423595235962359723598235992360023601236022360323604236052360623607236082360923610236112361223613236142361523616236172361823619236202362123622236232362423625236262362723628236292363023631236322363323634236352363623637236382363923640236412364223643236442364523646236472364823649236502365123652236532365423655236562365723658236592366023661236622366323664236652366623667236682366923670236712367223673236742367523676236772367823679236802368123682236832368423685236862368723688236892369023691236922369323694236952369623697236982369923700237012370223703237042370523706237072370823709237102371123712237132371423715237162371723718237192372023721237222372323724237252372623727237282372923730237312373223733237342373523736237372373823739237402374123742237432374423745237462374723748237492375023751237522375323754237552375623757237582375923760237612376223763237642376523766237672376823769237702377123772237732377423775237762377723778237792378023781237822378323784237852378623787237882378923790237912379223793237942379523796237972379823799238002380123802238032380423805238062380723808238092381023811238122381323814238152381623817238182381923820238212382223823238242382523826238272382823829238302383123832238332383423835238362383723838238392384023841238422384323844238452384623847238482384923850238512385223853238542385523856238572385823859238602386123862238632386423865238662386723868238692387023871238722387323874238752387623877238782387923880238812388223883238842388523886238872388823889238902389123892238932389423895238962389723898238992390023901239022390323904239052390623907239082390923910239112391223913239142391523916239172391823919239202392123922239232392423925239262392723928239292393023931239322393323934239352393623937239382393923940239412394223943239442394523946239472394823949239502395123952239532395423955239562395723958239592396023961239622396323964239652396623967239682396923970239712397223973239742397523976239772397823979239802398123982239832398423985239862398723988239892399023991239922399323994239952399623997239982399924000240012400224003240042400524006240072400824009240102401124012240132401424015240162401724018240192402024021240222402324024240252402624027240282402924030240312403224033240342403524036240372403824039240402404124042240432404424045240462404724048240492405024051240522405324054240552405624057240582405924060240612406224063240642406524066240672406824069240702407124072240732407424075240762407724078240792408024081240822408324084240852408624087240882408924090240912409224093240942409524096240972409824099241002410124102241032410424105241062410724108241092411024111241122411324114241152411624117241182411924120241212412224123241242412524126241272412824129241302413124132241332413424135241362413724138241392414024141241422414324144241452414624147241482414924150241512415224153241542415524156241572415824159241602416124162241632416424165241662416724168241692417024171241722417324174241752417624177241782417924180241812418224183241842418524186241872418824189241902419124192241932419424195241962419724198241992420024201242022420324204242052420624207242082420924210242112421224213242142421524216242172421824219242202422124222242232422424225242262422724228242292423024231242322423324234242352423624237242382423924240242412424224243242442424524246242472424824249242502425124252242532425424255242562425724258242592426024261242622426324264242652426624267242682426924270242712427224273242742427524276242772427824279242802428124282242832428424285242862428724288242892429024291242922429324294242952429624297242982429924300243012430224303243042430524306243072430824309243102431124312243132431424315243162431724318243192432024321243222432324324243252432624327243282432924330243312433224333243342433524336243372433824339243402434124342243432434424345243462434724348243492435024351243522435324354243552435624357243582435924360243612436224363243642436524366243672436824369243702437124372243732437424375243762437724378243792438024381243822438324384243852438624387243882438924390243912439224393243942439524396243972439824399244002440124402244032440424405244062440724408244092441024411244122441324414244152441624417244182441924420244212442224423244242442524426244272442824429244302443124432244332443424435244362443724438244392444024441244422444324444244452444624447244482444924450244512445224453244542445524456244572445824459244602446124462244632446424465244662446724468244692447024471244722447324474244752447624477244782447924480244812448224483244842448524486244872448824489244902449124492244932449424495244962449724498244992450024501245022450324504245052450624507245082450924510245112451224513245142451524516245172451824519245202452124522245232452424525245262452724528245292453024531245322453324534245352453624537245382453924540245412454224543245442454524546245472454824549245502455124552245532455424555245562455724558245592456024561245622456324564245652456624567245682456924570245712457224573245742457524576245772457824579245802458124582245832458424585245862458724588245892459024591245922459324594245952459624597245982459924600246012460224603246042460524606246072460824609246102461124612246132461424615246162461724618246192462024621246222462324624246252462624627246282462924630246312463224633246342463524636246372463824639246402464124642246432464424645246462464724648246492465024651246522465324654246552465624657246582465924660246612466224663246642466524666246672466824669246702467124672246732467424675246762467724678246792468024681246822468324684246852468624687246882468924690246912469224693246942469524696246972469824699247002470124702247032470424705247062470724708247092471024711247122471324714247152471624717247182471924720247212472224723247242472524726247272472824729247302473124732247332473424735247362473724738247392474024741247422474324744247452474624747247482474924750247512475224753247542475524756247572475824759247602476124762247632476424765247662476724768247692477024771247722477324774247752477624777247782477924780247812478224783247842478524786247872478824789247902479124792247932479424795247962479724798247992480024801248022480324804248052480624807248082480924810248112481224813248142481524816248172481824819248202482124822248232482424825248262482724828248292483024831248322483324834248352483624837248382483924840248412484224843248442484524846248472484824849248502485124852248532485424855248562485724858248592486024861248622486324864248652486624867248682486924870248712487224873248742487524876248772487824879248802488124882248832488424885248862488724888248892489024891248922489324894248952489624897248982489924900249012490224903249042490524906249072490824909249102491124912249132491424915249162491724918249192492024921249222492324924249252492624927249282492924930249312493224933249342493524936249372493824939249402494124942249432494424945249462494724948249492495024951249522495324954249552495624957249582495924960249612496224963249642496524966249672496824969249702497124972249732497424975249762497724978249792498024981249822498324984249852498624987249882498924990249912499224993249942499524996249972499824999250002500125002250032500425005250062500725008250092501025011250122501325014250152501625017250182501925020250212502225023250242502525026250272502825029250302503125032250332503425035250362503725038250392504025041250422504325044250452504625047250482504925050250512505225053250542505525056250572505825059250602506125062250632506425065250662506725068250692507025071250722507325074250752507625077250782507925080250812508225083250842508525086250872508825089250902509125092250932509425095250962509725098250992510025101251022510325104251052510625107251082510925110251112511225113251142511525116251172511825119251202512125122251232512425125251262512725128251292513025131251322513325134251352513625137251382513925140251412514225143251442514525146251472514825149251502515125152251532515425155251562515725158251592516025161251622516325164251652516625167251682516925170251712517225173251742517525176251772517825179251802518125182251832518425185251862518725188251892519025191251922519325194251952519625197251982519925200252012520225203252042520525206252072520825209252102521125212252132521425215252162521725218252192522025221252222522325224252252522625227252282522925230252312523225233252342523525236252372523825239252402524125242252432524425245252462524725248252492525025251252522525325254252552525625257252582525925260252612526225263252642526525266252672526825269252702527125272252732527425275252762527725278252792528025281252822528325284252852528625287252882528925290252912529225293252942529525296252972529825299253002530125302253032530425305253062530725308253092531025311253122531325314253152531625317253182531925320253212532225323253242532525326253272532825329253302533125332253332533425335253362533725338253392534025341253422534325344253452534625347253482534925350253512535225353253542535525356253572535825359253602536125362253632536425365253662536725368253692537025371253722537325374253752537625377253782537925380253812538225383253842538525386253872538825389253902539125392253932539425395253962539725398253992540025401254022540325404254052540625407254082540925410254112541225413254142541525416254172541825419254202542125422254232542425425254262542725428254292543025431254322543325434254352543625437254382543925440254412544225443254442544525446254472544825449254502545125452254532545425455254562545725458254592546025461254622546325464254652546625467254682546925470254712547225473254742547525476254772547825479254802548125482254832548425485254862548725488254892549025491254922549325494254952549625497254982549925500255012550225503255042550525506255072550825509255102551125512255132551425515255162551725518255192552025521255222552325524255252552625527255282552925530255312553225533255342553525536255372553825539255402554125542255432554425545255462554725548255492555025551255522555325554255552555625557255582555925560255612556225563255642556525566255672556825569255702557125572255732557425575255762557725578255792558025581255822558325584255852558625587255882558925590255912559225593255942559525596255972559825599256002560125602256032560425605256062560725608256092561025611256122561325614256152561625617256182561925620256212562225623256242562525626256272562825629256302563125632256332563425635256362563725638256392564025641256422564325644256452564625647256482564925650256512565225653256542565525656256572565825659256602566125662256632566425665256662566725668256692567025671256722567325674256752567625677256782567925680256812568225683256842568525686256872568825689256902569125692256932569425695256962569725698256992570025701257022570325704257052570625707257082570925710257112571225713257142571525716257172571825719257202572125722257232572425725257262572725728257292573025731257322573325734257352573625737257382573925740257412574225743257442574525746257472574825749257502575125752257532575425755257562575725758257592576025761257622576325764257652576625767257682576925770257712577225773257742577525776257772577825779257802578125782257832578425785257862578725788257892579025791257922579325794257952579625797257982579925800258012580225803258042580525806258072580825809258102581125812258132581425815258162581725818258192582025821258222582325824258252582625827258282582925830258312583225833258342583525836258372583825839258402584125842258432584425845258462584725848258492585025851258522585325854258552585625857258582585925860258612586225863258642586525866258672586825869258702587125872258732587425875258762587725878258792588025881258822588325884258852588625887258882588925890258912589225893258942589525896258972589825899259002590125902259032590425905259062590725908259092591025911259122591325914259152591625917259182591925920259212592225923259242592525926259272592825929259302593125932259332593425935259362593725938259392594025941259422594325944259452594625947259482594925950259512595225953259542595525956259572595825959259602596125962259632596425965259662596725968259692597025971259722597325974259752597625977259782597925980259812598225983259842598525986259872598825989259902599125992259932599425995259962599725998259992600026001260022600326004260052600626007260082600926010260112601226013260142601526016260172601826019260202602126022260232602426025260262602726028260292603026031260322603326034260352603626037260382603926040260412604226043260442604526046260472604826049260502605126052260532605426055260562605726058260592606026061260622606326064260652606626067260682606926070260712607226073260742607526076260772607826079260802608126082260832608426085260862608726088260892609026091260922609326094260952609626097260982609926100261012610226103261042610526106261072610826109261102611126112261132611426115261162611726118261192612026121261222612326124261252612626127261282612926130261312613226133261342613526136261372613826139261402614126142261432614426145261462614726148261492615026151261522615326154261552615626157261582615926160261612616226163261642616526166261672616826169261702617126172261732617426175261762617726178261792618026181261822618326184261852618626187261882618926190261912619226193261942619526196261972619826199262002620126202262032620426205262062620726208262092621026211262122621326214262152621626217262182621926220262212622226223262242622526226262272622826229262302623126232262332623426235262362623726238262392624026241262422624326244262452624626247262482624926250262512625226253262542625526256262572625826259262602626126262262632626426265262662626726268262692627026271262722627326274262752627626277262782627926280262812628226283262842628526286262872628826289262902629126292262932629426295262962629726298262992630026301263022630326304263052630626307263082630926310263112631226313263142631526316263172631826319263202632126322263232632426325263262632726328263292633026331263322633326334263352633626337263382633926340263412634226343263442634526346263472634826349263502635126352263532635426355263562635726358263592636026361263622636326364263652636626367263682636926370263712637226373263742637526376263772637826379263802638126382263832638426385263862638726388263892639026391263922639326394263952639626397263982639926400264012640226403264042640526406264072640826409264102641126412264132641426415264162641726418264192642026421264222642326424264252642626427264282642926430264312643226433264342643526436264372643826439264402644126442264432644426445264462644726448264492645026451264522645326454264552645626457264582645926460264612646226463264642646526466264672646826469264702647126472264732647426475264762647726478264792648026481264822648326484264852648626487264882648926490264912649226493264942649526496264972649826499265002650126502265032650426505265062650726508265092651026511265122651326514265152651626517265182651926520265212652226523265242652526526265272652826529265302653126532265332653426535265362653726538265392654026541265422654326544265452654626547265482654926550265512655226553265542655526556265572655826559265602656126562265632656426565265662656726568265692657026571265722657326574265752657626577265782657926580265812658226583265842658526586265872658826589265902659126592265932659426595265962659726598265992660026601266022660326604266052660626607266082660926610266112661226613266142661526616266172661826619266202662126622266232662426625266262662726628266292663026631266322663326634266352663626637266382663926640266412664226643266442664526646266472664826649266502665126652266532665426655266562665726658266592666026661266622666326664266652666626667266682666926670266712667226673266742667526676266772667826679266802668126682266832668426685266862668726688266892669026691266922669326694266952669626697266982669926700267012670226703267042670526706267072670826709267102671126712267132671426715267162671726718267192672026721267222672326724267252672626727267282672926730267312673226733267342673526736267372673826739267402674126742267432674426745267462674726748267492675026751267522675326754267552675626757267582675926760267612676226763267642676526766267672676826769267702677126772267732677426775267762677726778267792678026781267822678326784267852678626787267882678926790267912679226793267942679526796267972679826799268002680126802268032680426805268062680726808268092681026811268122681326814268152681626817268182681926820268212682226823268242682526826268272682826829268302683126832268332683426835268362683726838268392684026841268422684326844268452684626847268482684926850268512685226853268542685526856268572685826859268602686126862268632686426865268662686726868268692687026871268722687326874268752687626877268782687926880268812688226883268842688526886268872688826889268902689126892268932689426895268962689726898268992690026901269022690326904269052690626907269082690926910269112691226913269142691526916269172691826919269202692126922269232692426925269262692726928269292693026931269322693326934269352693626937269382693926940269412694226943269442694526946269472694826949269502695126952269532695426955269562695726958269592696026961269622696326964269652696626967269682696926970269712697226973269742697526976269772697826979269802698126982269832698426985269862698726988269892699026991269922699326994269952699626997269982699927000270012700227003270042700527006270072700827009270102701127012270132701427015270162701727018270192702027021270222702327024270252702627027270282702927030270312703227033270342703527036270372703827039270402704127042270432704427045270462704727048270492705027051270522705327054270552705627057270582705927060270612706227063270642706527066270672706827069270702707127072270732707427075270762707727078270792708027081270822708327084270852708627087270882708927090270912709227093270942709527096270972709827099271002710127102271032710427105271062710727108271092711027111271122711327114271152711627117271182711927120271212712227123271242712527126271272712827129271302713127132271332713427135271362713727138271392714027141271422714327144271452714627147271482714927150271512715227153271542715527156271572715827159271602716127162271632716427165271662716727168271692717027171271722717327174271752717627177271782717927180271812718227183271842718527186271872718827189271902719127192271932719427195271962719727198271992720027201272022720327204272052720627207272082720927210272112721227213272142721527216272172721827219272202722127222272232722427225272262722727228272292723027231272322723327234272352723627237272382723927240272412724227243272442724527246272472724827249272502725127252272532725427255272562725727258272592726027261272622726327264272652726627267272682726927270272712727227273272742727527276272772727827279272802728127282272832728427285272862728727288272892729027291272922729327294272952729627297272982729927300273012730227303273042730527306273072730827309273102731127312273132731427315273162731727318273192732027321273222732327324273252732627327273282732927330273312733227333273342733527336273372733827339273402734127342273432734427345273462734727348273492735027351273522735327354273552735627357273582735927360273612736227363273642736527366273672736827369273702737127372273732737427375273762737727378273792738027381273822738327384273852738627387273882738927390273912739227393273942739527396273972739827399274002740127402274032740427405274062740727408274092741027411274122741327414274152741627417274182741927420274212742227423274242742527426274272742827429274302743127432274332743427435274362743727438274392744027441274422744327444274452744627447274482744927450274512745227453274542745527456274572745827459274602746127462274632746427465274662746727468274692747027471274722747327474274752747627477274782747927480274812748227483274842748527486274872748827489274902749127492274932749427495274962749727498274992750027501275022750327504275052750627507275082750927510275112751227513275142751527516275172751827519275202752127522275232752427525275262752727528275292753027531275322753327534275352753627537275382753927540275412754227543275442754527546275472754827549275502755127552275532755427555275562755727558275592756027561275622756327564275652756627567275682756927570275712757227573275742757527576275772757827579275802758127582275832758427585275862758727588275892759027591275922759327594275952759627597275982759927600276012760227603276042760527606276072760827609276102761127612276132761427615276162761727618276192762027621276222762327624276252762627627276282762927630276312763227633276342763527636276372763827639276402764127642276432764427645276462764727648276492765027651276522765327654276552765627657276582765927660276612766227663276642766527666276672766827669276702767127672276732767427675276762767727678276792768027681276822768327684276852768627687276882768927690276912769227693276942769527696276972769827699277002770127702277032770427705277062770727708277092771027711277122771327714277152771627717277182771927720277212772227723277242772527726277272772827729277302773127732277332773427735277362773727738277392774027741277422774327744277452774627747277482774927750277512775227753277542775527756277572775827759277602776127762277632776427765277662776727768277692777027771277722777327774277752777627777277782777927780277812778227783277842778527786277872778827789277902779127792277932779427795277962779727798277992780027801278022780327804278052780627807278082780927810278112781227813278142781527816278172781827819278202782127822278232782427825278262782727828278292783027831278322783327834278352783627837278382783927840278412784227843278442784527846278472784827849278502785127852278532785427855278562785727858278592786027861278622786327864278652786627867278682786927870278712787227873278742787527876278772787827879278802788127882278832788427885278862788727888278892789027891278922789327894278952789627897278982789927900279012790227903279042790527906279072790827909279102791127912279132791427915279162791727918279192792027921279222792327924279252792627927279282792927930279312793227933279342793527936279372793827939279402794127942279432794427945279462794727948279492795027951279522795327954279552795627957279582795927960279612796227963279642796527966279672796827969279702797127972279732797427975279762797727978279792798027981279822798327984279852798627987279882798927990279912799227993279942799527996279972799827999280002800128002280032800428005280062800728008280092801028011280122801328014280152801628017280182801928020280212802228023280242802528026280272802828029280302803128032280332803428035280362803728038280392804028041280422804328044280452804628047280482804928050280512805228053280542805528056280572805828059280602806128062280632806428065280662806728068280692807028071280722807328074280752807628077280782807928080280812808228083280842808528086280872808828089280902809128092280932809428095280962809728098280992810028101281022810328104281052810628107281082810928110281112811228113281142811528116281172811828119281202812128122281232812428125281262812728128281292813028131281322813328134281352813628137281382813928140281412814228143281442814528146281472814828149281502815128152281532815428155281562815728158281592816028161281622816328164281652816628167281682816928170281712817228173281742817528176281772817828179281802818128182281832818428185281862818728188281892819028191281922819328194281952819628197281982819928200282012820228203282042820528206282072820828209282102821128212282132821428215282162821728218282192822028221282222822328224282252822628227282282822928230282312823228233282342823528236282372823828239282402824128242282432824428245282462824728248282492825028251282522825328254282552825628257282582825928260282612826228263282642826528266282672826828269282702827128272282732827428275282762827728278282792828028281282822828328284282852828628287282882828928290282912829228293282942829528296282972829828299283002830128302283032830428305283062830728308283092831028311283122831328314283152831628317283182831928320283212832228323283242832528326283272832828329283302833128332283332833428335283362833728338283392834028341283422834328344283452834628347283482834928350283512835228353283542835528356283572835828359283602836128362283632836428365283662836728368283692837028371283722837328374283752837628377283782837928380283812838228383283842838528386283872838828389283902839128392283932839428395283962839728398283992840028401284022840328404284052840628407284082840928410284112841228413284142841528416284172841828419284202842128422284232842428425284262842728428284292843028431284322843328434284352843628437284382843928440284412844228443284442844528446284472844828449284502845128452284532845428455284562845728458284592846028461284622846328464284652846628467284682846928470284712847228473284742847528476284772847828479284802848128482284832848428485284862848728488284892849028491284922849328494284952849628497284982849928500285012850228503285042850528506285072850828509285102851128512285132851428515285162851728518285192852028521285222852328524285252852628527285282852928530285312853228533285342853528536285372853828539285402854128542285432854428545285462854728548285492855028551285522855328554285552855628557285582855928560285612856228563285642856528566285672856828569285702857128572285732857428575285762857728578285792858028581285822858328584285852858628587285882858928590285912859228593285942859528596285972859828599286002860128602286032860428605286062860728608286092861028611286122861328614286152861628617286182861928620286212862228623286242862528626286272862828629286302863128632286332863428635286362863728638286392864028641286422864328644286452864628647286482864928650286512865228653286542865528656286572865828659286602866128662286632866428665286662866728668286692867028671286722867328674286752867628677286782867928680286812868228683286842868528686286872868828689286902869128692286932869428695286962869728698286992870028701287022870328704287052870628707287082870928710287112871228713287142871528716287172871828719287202872128722287232872428725287262872728728287292873028731287322873328734287352873628737287382873928740287412874228743287442874528746287472874828749287502875128752287532875428755287562875728758287592876028761287622876328764287652876628767287682876928770287712877228773287742877528776287772877828779287802878128782287832878428785287862878728788287892879028791287922879328794287952879628797287982879928800288012880228803288042880528806288072880828809288102881128812288132881428815288162881728818288192882028821288222882328824288252882628827288282882928830288312883228833288342883528836288372883828839288402884128842288432884428845288462884728848288492885028851288522885328854288552885628857288582885928860288612886228863288642886528866288672886828869288702887128872288732887428875288762887728878288792888028881288822888328884288852888628887288882888928890288912889228893288942889528896288972889828899289002890128902289032890428905289062890728908289092891028911289122891328914289152891628917289182891928920289212892228923289242892528926289272892828929289302893128932289332893428935289362893728938289392894028941289422894328944289452894628947289482894928950289512895228953289542895528956289572895828959289602896128962289632896428965289662896728968289692897028971289722897328974289752897628977289782897928980289812898228983289842898528986289872898828989289902899128992289932899428995289962899728998289992900029001290022900329004290052900629007290082900929010290112901229013290142901529016290172901829019290202902129022290232902429025290262902729028290292903029031290322903329034290352903629037290382903929040290412904229043290442904529046290472904829049290502905129052290532905429055290562905729058290592906029061290622906329064290652906629067290682906929070290712907229073290742907529076290772907829079290802908129082290832908429085290862908729088290892909029091290922909329094290952909629097290982909929100291012910229103291042910529106291072910829109291102911129112291132911429115291162911729118291192912029121291222912329124291252912629127291282912929130291312913229133291342913529136291372913829139291402914129142291432914429145291462914729148291492915029151291522915329154291552915629157291582915929160291612916229163291642916529166291672916829169291702917129172291732917429175291762917729178291792918029181291822918329184291852918629187291882918929190291912919229193291942919529196291972919829199292002920129202292032920429205292062920729208292092921029211292122921329214292152921629217292182921929220292212922229223292242922529226292272922829229292302923129232292332923429235292362923729238292392924029241292422924329244292452924629247292482924929250292512925229253292542925529256292572925829259292602926129262292632926429265292662926729268292692927029271292722927329274292752927629277292782927929280292812928229283292842928529286292872928829289292902929129292292932929429295292962929729298292992930029301293022930329304293052930629307293082930929310293112931229313293142931529316293172931829319293202932129322293232932429325293262932729328293292933029331293322933329334293352933629337293382933929340293412934229343293442934529346293472934829349293502935129352293532935429355293562935729358293592936029361293622936329364293652936629367293682936929370293712937229373293742937529376293772937829379293802938129382293832938429385293862938729388293892939029391293922939329394293952939629397293982939929400294012940229403294042940529406294072940829409294102941129412294132941429415294162941729418294192942029421294222942329424294252942629427294282942929430294312943229433294342943529436294372943829439294402944129442294432944429445294462944729448294492945029451294522945329454294552945629457294582945929460294612946229463294642946529466294672946829469294702947129472294732947429475294762947729478294792948029481294822948329484294852948629487294882948929490294912949229493294942949529496294972949829499295002950129502295032950429505295062950729508295092951029511295122951329514295152951629517295182951929520295212952229523295242952529526295272952829529295302953129532295332953429535295362953729538295392954029541295422954329544295452954629547295482954929550295512955229553295542955529556295572955829559295602956129562295632956429565295662956729568295692957029571295722957329574295752957629577295782957929580295812958229583295842958529586295872958829589295902959129592295932959429595295962959729598295992960029601296022960329604296052960629607296082960929610296112961229613296142961529616296172961829619296202962129622296232962429625296262962729628296292963029631296322963329634296352963629637296382963929640296412964229643296442964529646296472964829649296502965129652296532965429655296562965729658296592966029661296622966329664296652966629667296682966929670296712967229673296742967529676296772967829679296802968129682296832968429685296862968729688296892969029691296922969329694296952969629697296982969929700297012970229703297042970529706297072970829709297102971129712297132971429715297162971729718297192972029721297222972329724297252972629727297282972929730297312973229733297342973529736297372973829739297402974129742297432974429745297462974729748297492975029751297522975329754297552975629757297582975929760297612976229763297642976529766297672976829769297702977129772297732977429775297762977729778297792978029781297822978329784297852978629787297882978929790297912979229793297942979529796297972979829799298002980129802298032980429805298062980729808298092981029811298122981329814298152981629817298182981929820298212982229823298242982529826298272982829829298302983129832298332983429835298362983729838298392984029841298422984329844298452984629847298482984929850298512985229853298542985529856298572985829859298602986129862298632986429865298662986729868298692987029871298722987329874298752987629877298782987929880298812988229883298842988529886298872988829889298902989129892298932989429895298962989729898298992990029901299022990329904299052990629907299082990929910299112991229913299142991529916299172991829919299202992129922299232992429925299262992729928299292993029931299322993329934299352993629937299382993929940299412994229943299442994529946299472994829949299502995129952299532995429955299562995729958299592996029961299622996329964299652996629967299682996929970299712997229973299742997529976299772997829979299802998129982299832998429985299862998729988299892999029991299922999329994299952999629997299982999930000300013000230003300043000530006300073000830009300103001130012300133001430015300163001730018300193002030021300223002330024300253002630027300283002930030300313003230033300343003530036300373003830039300403004130042300433004430045300463004730048300493005030051300523005330054300553005630057300583005930060300613006230063300643006530066300673006830069300703007130072300733007430075300763007730078300793008030081300823008330084300853008630087300883008930090300913009230093300943009530096300973009830099301003010130102301033010430105301063010730108301093011030111301123011330114301153011630117301183011930120301213012230123301243012530126301273012830129301303013130132301333013430135301363013730138301393014030141301423014330144301453014630147301483014930150301513015230153301543015530156301573015830159301603016130162301633016430165301663016730168301693017030171301723017330174301753017630177301783017930180301813018230183301843018530186301873018830189301903019130192301933019430195301963019730198301993020030201302023020330204302053020630207302083020930210302113021230213302143021530216302173021830219302203022130222302233022430225302263022730228302293023030231302323023330234302353023630237302383023930240302413024230243302443024530246302473024830249302503025130252302533025430255302563025730258302593026030261302623026330264302653026630267302683026930270302713027230273302743027530276302773027830279302803028130282302833028430285302863028730288302893029030291302923029330294302953029630297302983029930300303013030230303303043030530306303073030830309303103031130312303133031430315303163031730318303193032030321303223032330324303253032630327303283032930330303313033230333303343033530336303373033830339303403034130342303433034430345303463034730348303493035030351303523035330354303553035630357303583035930360303613036230363303643036530366303673036830369303703037130372303733037430375303763037730378303793038030381303823038330384303853038630387303883038930390303913039230393303943039530396303973039830399304003040130402304033040430405304063040730408304093041030411304123041330414304153041630417304183041930420304213042230423304243042530426304273042830429304303043130432304333043430435304363043730438304393044030441304423044330444304453044630447304483044930450304513045230453304543045530456304573045830459304603046130462304633046430465304663046730468304693047030471304723047330474304753047630477304783047930480304813048230483304843048530486304873048830489304903049130492304933049430495304963049730498304993050030501305023050330504305053050630507305083050930510305113051230513305143051530516305173051830519305203052130522305233052430525305263052730528305293053030531305323053330534305353053630537305383053930540305413054230543305443054530546305473054830549305503055130552305533055430555305563055730558305593056030561305623056330564305653056630567305683056930570305713057230573305743057530576305773057830579305803058130582305833058430585305863058730588305893059030591305923059330594305953059630597305983059930600306013060230603306043060530606306073060830609306103061130612306133061430615306163061730618306193062030621306223062330624306253062630627306283062930630306313063230633306343063530636306373063830639306403064130642306433064430645306463064730648306493065030651306523065330654306553065630657306583065930660306613066230663306643066530666306673066830669306703067130672306733067430675306763067730678306793068030681306823068330684306853068630687306883068930690306913069230693306943069530696306973069830699307003070130702307033070430705307063070730708307093071030711307123071330714307153071630717307183071930720307213072230723307243072530726307273072830729307303073130732307333073430735307363073730738307393074030741307423074330744307453074630747307483074930750307513075230753307543075530756307573075830759307603076130762307633076430765307663076730768307693077030771307723077330774307753077630777307783077930780307813078230783307843078530786307873078830789307903079130792307933079430795307963079730798307993080030801308023080330804308053080630807308083080930810308113081230813308143081530816308173081830819308203082130822308233082430825308263082730828308293083030831308323083330834308353083630837308383083930840308413084230843308443084530846308473084830849308503085130852308533085430855308563085730858308593086030861308623086330864308653086630867308683086930870308713087230873308743087530876308773087830879308803088130882308833088430885308863088730888308893089030891308923089330894308953089630897308983089930900309013090230903309043090530906309073090830909309103091130912309133091430915309163091730918309193092030921309223092330924309253092630927309283092930930309313093230933309343093530936309373093830939309403094130942309433094430945309463094730948309493095030951309523095330954309553095630957309583095930960309613096230963309643096530966309673096830969309703097130972309733097430975309763097730978309793098030981309823098330984309853098630987309883098930990309913099230993309943099530996309973099830999310003100131002310033100431005310063100731008310093101031011310123101331014310153101631017310183101931020310213102231023310243102531026310273102831029310303103131032310333103431035310363103731038310393104031041310423104331044310453104631047310483104931050310513105231053310543105531056310573105831059310603106131062310633106431065310663106731068310693107031071310723107331074310753107631077310783107931080310813108231083310843108531086310873108831089310903109131092310933109431095310963109731098310993110031101311023110331104311053110631107311083110931110311113111231113311143111531116311173111831119311203112131122311233112431125311263112731128311293113031131311323113331134311353113631137311383113931140311413114231143311443114531146311473114831149311503115131152311533115431155311563115731158311593116031161311623116331164311653116631167311683116931170311713117231173311743117531176311773117831179311803118131182311833118431185311863118731188311893119031191311923119331194311953119631197311983119931200312013120231203312043120531206312073120831209312103121131212312133121431215312163121731218312193122031221312223122331224312253122631227312283122931230312313123231233312343123531236312373123831239312403124131242312433124431245312463124731248312493125031251312523125331254312553125631257312583125931260312613126231263312643126531266312673126831269312703127131272312733127431275312763127731278312793128031281312823128331284312853128631287312883128931290312913129231293312943129531296312973129831299313003130131302313033130431305313063130731308313093131031311313123131331314313153131631317313183131931320313213132231323313243132531326313273132831329313303133131332313333133431335313363133731338313393134031341313423134331344313453134631347313483134931350313513135231353313543135531356313573135831359313603136131362313633136431365313663136731368313693137031371313723137331374313753137631377313783137931380313813138231383313843138531386313873138831389313903139131392313933139431395313963139731398313993140031401314023140331404314053140631407314083140931410314113141231413314143141531416314173141831419314203142131422314233142431425314263142731428314293143031431314323143331434314353143631437314383143931440314413144231443314443144531446314473144831449314503145131452314533145431455314563145731458314593146031461314623146331464314653146631467314683146931470314713147231473314743147531476314773147831479314803148131482314833148431485314863148731488314893149031491314923149331494314953149631497314983149931500315013150231503315043150531506315073150831509315103151131512315133151431515315163151731518315193152031521315223152331524315253152631527315283152931530315313153231533315343153531536315373153831539315403154131542315433154431545315463154731548315493155031551315523155331554315553155631557315583155931560315613156231563315643156531566315673156831569315703157131572315733157431575315763157731578315793158031581315823158331584315853158631587315883158931590315913159231593315943159531596315973159831599316003160131602316033160431605316063160731608316093161031611316123161331614316153161631617316183161931620316213162231623316243162531626316273162831629316303163131632316333163431635316363163731638316393164031641316423164331644316453164631647316483164931650316513165231653316543165531656316573165831659316603166131662316633166431665316663166731668316693167031671316723167331674316753167631677316783167931680316813168231683316843168531686316873168831689316903169131692316933169431695316963169731698316993170031701317023170331704317053170631707317083170931710317113171231713317143171531716317173171831719317203172131722317233172431725317263172731728317293173031731317323173331734317353173631737317383173931740317413174231743317443174531746317473174831749317503175131752317533175431755317563175731758317593176031761317623176331764317653176631767317683176931770317713177231773317743177531776317773177831779317803178131782317833178431785317863178731788317893179031791317923179331794317953179631797317983179931800318013180231803318043180531806318073180831809318103181131812318133181431815318163181731818318193182031821318223182331824318253182631827318283182931830318313183231833318343183531836318373183831839318403184131842318433184431845318463184731848318493185031851318523185331854318553185631857318583185931860318613186231863318643186531866318673186831869318703187131872318733187431875318763187731878318793188031881318823188331884318853188631887318883188931890318913189231893318943189531896318973189831899319003190131902319033190431905319063190731908319093191031911319123191331914319153191631917319183191931920319213192231923319243192531926319273192831929319303193131932319333193431935319363193731938319393194031941319423194331944319453194631947319483194931950319513195231953319543195531956319573195831959319603196131962319633196431965319663196731968319693197031971319723197331974319753197631977319783197931980319813198231983319843198531986319873198831989319903199131992319933199431995319963199731998319993200032001320023200332004320053200632007320083200932010320113201232013320143201532016320173201832019320203202132022320233202432025320263202732028320293203032031320323203332034320353203632037320383203932040320413204232043320443204532046320473204832049320503205132052320533205432055320563205732058320593206032061320623206332064320653206632067320683206932070320713207232073320743207532076320773207832079320803208132082320833208432085320863208732088320893209032091320923209332094320953209632097320983209932100321013210232103321043210532106321073210832109321103211132112321133211432115321163211732118321193212032121321223212332124321253212632127321283212932130321313213232133321343213532136321373213832139321403214132142321433214432145321463214732148321493215032151321523215332154321553215632157321583215932160321613216232163321643216532166321673216832169321703217132172321733217432175321763217732178321793218032181321823218332184321853218632187321883218932190321913219232193321943219532196321973219832199322003220132202322033220432205322063220732208322093221032211322123221332214322153221632217322183221932220322213222232223322243222532226322273222832229322303223132232322333223432235322363223732238322393224032241322423224332244322453224632247322483224932250322513225232253322543225532256322573225832259322603226132262322633226432265322663226732268322693227032271322723227332274322753227632277322783227932280322813228232283322843228532286322873228832289322903229132292322933229432295322963229732298322993230032301323023230332304323053230632307323083230932310323113231232313323143231532316323173231832319323203232132322323233232432325323263232732328323293233032331323323233332334323353233632337323383233932340323413234232343323443234532346323473234832349323503235132352323533235432355323563235732358323593236032361323623236332364323653236632367323683236932370323713237232373323743237532376323773237832379323803238132382323833238432385323863238732388323893239032391323923239332394323953239632397323983239932400324013240232403324043240532406324073240832409324103241132412324133241432415324163241732418324193242032421324223242332424324253242632427324283242932430324313243232433324343243532436324373243832439324403244132442324433244432445324463244732448324493245032451324523245332454324553245632457324583245932460324613246232463324643246532466324673246832469324703247132472324733247432475324763247732478324793248032481324823248332484324853248632487324883248932490324913249232493324943249532496324973249832499325003250132502325033250432505325063250732508325093251032511325123251332514325153251632517325183251932520325213252232523325243252532526325273252832529325303253132532325333253432535325363253732538325393254032541325423254332544325453254632547325483254932550325513255232553325543255532556325573255832559325603256132562325633256432565325663256732568325693257032571325723257332574325753257632577325783257932580325813258232583325843258532586325873258832589325903259132592325933259432595325963259732598325993260032601326023260332604326053260632607326083260932610326113261232613326143261532616326173261832619326203262132622326233262432625326263262732628326293263032631326323263332634326353263632637326383263932640326413264232643326443264532646326473264832649326503265132652326533265432655326563265732658326593266032661326623266332664326653266632667326683266932670326713267232673326743267532676326773267832679326803268132682326833268432685326863268732688326893269032691326923269332694326953269632697326983269932700327013270232703327043270532706327073270832709327103271132712327133271432715327163271732718327193272032721327223272332724327253272632727327283272932730327313273232733327343273532736327373273832739327403274132742327433274432745327463274732748327493275032751327523275332754327553275632757327583275932760327613276232763327643276532766327673276832769327703277132772327733277432775327763277732778327793278032781327823278332784327853278632787327883278932790327913279232793327943279532796327973279832799328003280132802328033280432805328063280732808328093281032811328123281332814328153281632817328183281932820328213282232823328243282532826328273282832829328303283132832328333283432835328363283732838328393284032841328423284332844328453284632847328483284932850328513285232853328543285532856328573285832859328603286132862328633286432865328663286732868328693287032871328723287332874328753287632877328783287932880328813288232883328843288532886328873288832889328903289132892328933289432895328963289732898328993290032901329023290332904329053290632907329083290932910329113291232913329143291532916329173291832919329203292132922329233292432925329263292732928329293293032931329323293332934329353293632937329383293932940329413294232943329443294532946329473294832949329503295132952329533295432955329563295732958329593296032961329623296332964329653296632967329683296932970329713297232973329743297532976329773297832979329803298132982329833298432985329863298732988329893299032991329923299332994329953299632997329983299933000330013300233003330043300533006330073300833009330103301133012330133301433015330163301733018330193302033021330223302333024330253302633027330283302933030330313303233033330343303533036330373303833039330403304133042330433304433045330463304733048330493305033051330523305333054330553305633057330583305933060330613306233063330643306533066330673306833069330703307133072330733307433075330763307733078330793308033081330823308333084330853308633087330883308933090330913309233093330943309533096330973309833099331003310133102331033310433105331063310733108331093311033111331123311333114331153311633117331183311933120331213312233123331243312533126331273312833129331303313133132331333313433135331363313733138331393314033141331423314333144331453314633147331483314933150331513315233153331543315533156331573315833159331603316133162331633316433165331663316733168331693317033171331723317333174331753317633177331783317933180331813318233183331843318533186331873318833189331903319133192331933319433195331963319733198331993320033201332023320333204332053320633207332083320933210332113321233213332143321533216332173321833219332203322133222332233322433225332263322733228332293323033231332323323333234332353323633237332383323933240332413324233243332443324533246332473324833249332503325133252332533325433255332563325733258332593326033261332623326333264332653326633267332683326933270332713327233273332743327533276332773327833279332803328133282332833328433285332863328733288332893329033291332923329333294332953329633297332983329933300333013330233303333043330533306333073330833309333103331133312333133331433315333163331733318333193332033321333223332333324333253332633327333283332933330333313333233333333343333533336333373333833339333403334133342333433334433345333463334733348333493335033351333523335333354333553335633357333583335933360333613336233363333643336533366333673336833369333703337133372333733337433375333763337733378333793338033381333823338333384333853338633387333883338933390333913339233393333943339533396333973339833399334003340133402334033340433405334063340733408334093341033411334123341333414334153341633417334183341933420334213342233423334243342533426334273342833429334303343133432334333343433435334363343733438334393344033441334423344333444334453344633447334483344933450334513345233453334543345533456334573345833459334603346133462334633346433465334663346733468 |
- {
- This file is part of the Free Component Library (FCL)
- Copyright (c) 2018 by Michael Van Canneyt
- Unit tests for Pascal-to-Javascript converter class.
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************
- Examples:
- ./testpas2js --suite=TTestModule.TestEmptyProgram
- ./testpas2js --suite=TTestModule.TestEmptyUnit
- }
- unit TCModules;
- {$mode objfpc}{$H+}
- interface
- uses
- Classes, SysUtils, fpcunit, testregistry, contnrs,
- jstree, jswriter, jsbase,
- PasTree, PScanner, PasResolver, PParser, PasResolveEval,
- FPPas2Js;
- const
- // default parser+scanner options
- po_tcmodules = po_Pas2js+[po_KeepScannerError];
- co_tcmodules = [];
- type
- TSrcMarkerKind = (
- mkLabel,
- mkResolverReference,
- mkDirectReference
- );
- PSrcMarker = ^TSrcMarker;
- TSrcMarker = record
- Kind: TSrcMarkerKind;
- Filename: string;
- Row: integer;
- StartCol, EndCol: integer; // token start, end column
- Identifier: string;
- Next: PSrcMarker;
- end;
- TSystemUnitPart = (
- supTObject,
- supTVarRec,
- supTypeInfo,
- supTInterfacedObject,
- supWriteln
- );
- TSystemUnitParts = set of TSystemUnitPart;
- { TTestHintMessage }
- TTestHintMessage = class
- public
- Id: int64;
- MsgType: TMessageType;
- MsgNumber: integer;
- Msg: string;
- SourcePos: TPasSourcePos;
- end;
- { TTestPasParser }
- TTestPasParser = Class(TPasParser)
- end;
- TOnFindUnit = function(const aUnitName: String): TPasModule of object;
- { TTestEnginePasResolver }
- TTestEnginePasResolver = class(TPas2JsResolver)
- private
- FFilename: string;
- FModule: TPasModule;
- FOnFindUnit: TOnFindUnit;
- FParser: TTestPasParser;
- FStreamResolver: TStreamResolver;
- FScanner: TPas2jsPasScanner;
- FSource: string;
- public
- destructor Destroy; override;
- function FindUnit(const AName, InFilename: String; NameExpr,
- InFileExpr: TPasExpr): TPasModule; override;
- procedure UsedInterfacesFinished(Section: TPasSection); override;
- property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
- property Filename: string read FFilename write FFilename;
- property StreamResolver: TStreamResolver read FStreamResolver write FStreamResolver;
- property Scanner: TPas2jsPasScanner read FScanner write FScanner;
- property Parser: TTestPasParser read FParser write FParser;
- property Source: string read FSource write FSource;
- property Module: TPasModule read FModule;
- end;
- { TCustomTestModule }
- TCustomTestModule = Class(TTestCase)
- private
- FConverter: TPasToJSConverter;
- FEngine: TTestEnginePasResolver;
- FExpectedErrorClass: ExceptClass;
- FExpectedErrorMsg: string;
- FExpectedErrorNumber: integer;
- FFilename: string;
- FFileResolver: TStreamResolver;
- FHub: TPas2JSResolverHub;
- FJSImplementationUses: TJSArrayLiteral;
- FJSInitBody: TJSFunctionBody;
- FJSImplentationUses: TJSArrayLiteral;
- FJSInterfaceUses: TJSArrayLiteral;
- FJSModule: TJSSourceElements;
- FJSModuleSrc: TJSSourceElements;
- FJSSource: TStringList;
- FModule: TPasModule;
- FJSModuleCallArgs: TJSArguments;
- FModules: TObjectList;// list of TTestEnginePasResolver
- FParser: TTestPasParser;
- FPasProgram: TPasProgram;
- FHintMsgs: TObjectList; // list of TTestHintMessage
- FHintMsgsGood: TFPList; // list of TTestHintMessage marked as expected
- FJSRegModuleCall: TJSCallExpression;
- FScanner: TPas2jsPasScanner;
- FSkipTests: boolean;
- FSource: TStringList;
- FFirstPasStatement: TPasImplBlock;
- FWithTypeInfo: boolean;
- {$IFDEF EnablePasTreeGlobalRefCount}
- FElementRefCountAtSetup: int64;
- {$ENDIF}
- function GetMsgCount: integer;
- function GetMsgs(Index: integer): TTestHintMessage;
- function GetResolverCount: integer;
- function GetResolvers(Index: integer): TTestEnginePasResolver;
- function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
- procedure OnParserLog(Sender: TObject; const Msg: String);
- procedure OnPasResolverLog(Sender: TObject; const Msg: String);
- procedure OnScannerLog(Sender: TObject; const Msg: String);
- procedure SetWithTypeInfo(const AValue: boolean);
- protected
- procedure SetUp; override;
- function CreateConverter: TPasToJSConverter; virtual;
- function LoadUnit(const aUnitName: String): TPasModule;
- procedure InitScanner(aScanner: TPas2jsPasScanner); virtual;
- procedure TearDown; override;
- Procedure Add(Line: string); virtual;
- Procedure Add(const Lines: array of string);
- Procedure StartParsing; virtual;
- procedure ParseModuleQueue; virtual;
- procedure ParseModule; virtual;
- procedure ParseProgram; virtual;
- procedure ParseUnit; virtual;
- protected
- function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual;
- function AddModule(aFilename: string): TTestEnginePasResolver; virtual;
- function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual;
- function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
- ImplementationSrc: string): TTestEnginePasResolver; virtual;
- procedure AddSystemUnit(Parts: TSystemUnitParts = []); virtual;
- procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
- procedure StartUnit(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
- procedure ConvertModule; virtual;
- procedure ConvertProgram; virtual;
- procedure ConvertUnit; virtual;
- function ConvertJSModuleToString(El: TJSElement): string; virtual;
- procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
- function GetDottedIdentifier(El: TJSElement): string;
- procedure CheckSource(Msg,Statements: String; InitStatements: string = '';
- ImplStatements: string = ''); virtual;
- procedure CheckDiff(Msg, Expected, Actual: string); virtual;
- procedure CheckUnit(Filename, ExpectedSrc: string); virtual;
- procedure CheckHint(MsgType: TMessageType; MsgNumber: integer;
- Msg: string; Marker: PSrcMarker = nil); virtual;
- procedure CheckResolverUnexpectedHints(WithSourcePos: boolean = false); virtual;
- procedure SetExpectedScannerError(Msg: string; MsgNumber: integer);
- procedure SetExpectedParserError(Msg: string; MsgNumber: integer);
- procedure SetExpectedPasResolverError(Msg: string; MsgNumber: integer);
- procedure SetExpectedConverterError(Msg: string; MsgNumber: integer);
- function IsErrorExpected(E: Exception): boolean;
- procedure HandleScannerError(E: EScannerError);
- procedure HandleParserError(E: EParserError);
- procedure HandlePasResolveError(E: EPasResolve);
- procedure HandlePas2JSError(E: EPas2JS);
- procedure HandleException(E: Exception);
- procedure FailException(E: Exception);
- procedure WriteSources(const aFilename: string; aRow, aCol: integer);
- function IndexOfResolver(const Filename: string): integer;
- function GetResolver(const Filename: string): TTestEnginePasResolver;
- function GetDefaultNamespace: string;
- property PasProgram: TPasProgram Read FPasProgram;
- property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
- property ResolverCount: integer read GetResolverCount;
- property Engine: TTestEnginePasResolver read FEngine;
- property Filename: string read FFilename;
- Property Module: TPasModule Read FModule;
- property FirstPasStatement: TPasImplBlock read FFirstPasStatement;
- property Converter: TPasToJSConverter read FConverter;
- property JSSource: TStringList read FJSSource;
- property JSModule: TJSSourceElements read FJSModule;
- property JSRegModuleCall: TJSCallExpression read FJSRegModuleCall;
- property JSModuleCallArgs: TJSArguments read FJSModuleCallArgs;
- property JSImplementationUses: TJSArrayLiteral read FJSImplementationUses;
- property JSInterfaceUses: TJSArrayLiteral read FJSInterfaceUses;
- property JSModuleSrc: TJSSourceElements read FJSModuleSrc;
- property JSInitBody: TJSFunctionBody read FJSInitBody;
- property ExpectedErrorClass: ExceptClass read FExpectedErrorClass write FExpectedErrorClass;
- property ExpectedErrorMsg: string read FExpectedErrorMsg write FExpectedErrorMsg;
- property ExpectedErrorNumber: integer read FExpectedErrorNumber write FExpectedErrorNumber;
- property SkipTests: boolean read FSkipTests write FSkipTests;
- public
- constructor Create; override;
- destructor Destroy; override;
- property Hub: TPas2JSResolverHub read FHub;
- property Source: TStringList read FSource;
- property FileResolver: TStreamResolver read FFileResolver;
- property Scanner: TPas2jsPasScanner read FScanner;
- property Parser: TTestPasParser read FParser;
- property MsgCount: integer read GetMsgCount;
- property Msgs[Index: integer]: TTestHintMessage read GetMsgs;
- property WithTypeInfo: boolean read FWithTypeInfo write SetWithTypeInfo;
- end;
- { TTestModule }
- TTestModule = class(TCustomTestModule)
- Published
- Procedure TestReservedWords;
- // program, units, includes
- Procedure TestEmptyProgram;
- Procedure TestEmptyProgramUseStrict;
- Procedure TestEmptyUnit;
- Procedure TestEmptyUnitUseStrict;
- Procedure TestDottedUnitNames;
- Procedure TestDottedUnitNameImpl;
- Procedure TestDottedUnitExpr;
- Procedure Test_ModeFPCFail;
- Procedure Test_ModeSwitchCBlocksFail;
- Procedure TestUnit_UseSystem;
- Procedure TestUnit_Intf1Impl2Intf1;
- Procedure TestIncludeVersion;
- // vars/const
- Procedure TestVarInt;
- Procedure TestVarBaseTypes;
- Procedure TestBaseTypeSingleFail;
- Procedure TestBaseTypeExtendedFail;
- Procedure TestConstBaseTypes;
- Procedure TestUnitImplVars;
- Procedure TestUnitImplConsts;
- Procedure TestUnitImplRecord;
- Procedure TestRenameJSNameConflict;
- Procedure TestLocalConst;
- Procedure TestVarExternal;
- Procedure TestVarExternalOtherUnit;
- Procedure TestVarAbsoluteFail;
- Procedure TestConstExternal;
- // numbers
- Procedure TestDouble;
- Procedure TestInteger;
- Procedure TestIntegerRange;
- Procedure TestIntegerTypecasts;
- Procedure TestInteger_BitwiseShrNativeInt;
- Procedure TestInteger_BitwiseShlNativeInt;
- Procedure TestInteger_SystemFunc;
- Procedure TestCurrency;
- Procedure TestForBoolDo;
- Procedure TestForIntDo;
- Procedure TestForIntInDo;
- // strings
- Procedure TestCharConst;
- Procedure TestChar_Compare;
- Procedure TestChar_BuiltInProcs;
- Procedure TestStringConst;
- Procedure TestStringConst_InvalidUTF16;
- Procedure TestStringConstSurrogate;
- Procedure TestString_Length;
- Procedure TestString_Compare;
- Procedure TestString_SetLength;
- Procedure TestString_CharAt;
- Procedure TestStringHMinusFail;
- Procedure TestStr;
- Procedure TestBaseType_AnsiStringFail;
- Procedure TestBaseType_WideStringFail;
- Procedure TestBaseType_ShortStringFail;
- Procedure TestBaseType_RawByteStringFail;
- Procedure TestTypeShortstring_Fail;
- Procedure TestCharSet_Custom;
- Procedure TestWideChar;
- Procedure TestForCharDo;
- Procedure TestForCharInDo;
- // alias types
- Procedure TestAliasTypeRef;
- Procedure TestTypeCast_BaseTypes;
- Procedure TestTypeCast_AliasBaseTypes;
- // functions
- Procedure TestEmptyProc;
- Procedure TestProcOneParam;
- Procedure TestFunctionWithoutParams;
- Procedure TestProcedureWithoutParams;
- Procedure TestPrgProcVar;
- Procedure TestProcTwoArgs;
- Procedure TestProc_DefaultValue;
- Procedure TestUnitProcVar;
- Procedure TestImplProc;
- Procedure TestFunctionResult;
- Procedure TestNestedProc;
- Procedure TestNestedProc_ResultString;
- Procedure TestForwardProc;
- Procedure TestNestedForwardProc;
- Procedure TestAssignFunctionResult;
- Procedure TestFunctionResultInCondition;
- Procedure TestFunctionResultInForLoop;
- Procedure TestFunctionResultInTypeCast;
- Procedure TestExit;
- Procedure TestExit_ResultInFinally;
- Procedure TestBreak;
- Procedure TestBreakAsVar;
- Procedure TestContinue;
- Procedure TestProc_External;
- Procedure TestProc_ExternalOtherUnit;
- Procedure TestProc_Asm;
- Procedure TestProc_AsmSubBlock;
- Procedure TestProc_Assembler;
- Procedure TestProc_VarParam;
- Procedure TestProc_VarParamString;
- Procedure TestProc_VarParamV;
- Procedure TestProc_Overload;
- Procedure TestProc_OverloadForward;
- Procedure TestProc_OverloadIntfImpl;
- Procedure TestProc_OverloadNested;
- Procedure TestProc_OverloadNestedForward;
- Procedure TestProc_OverloadUnitCycle;
- Procedure TestProc_Varargs;
- Procedure TestProc_ConstOrder;
- Procedure TestProc_DuplicateConst;
- Procedure TestProc_LocalVarAbsolute;
- Procedure TestProc_LocalVarInit;
- Procedure TestProc_ReservedWords;
- Procedure TestProc_ConstRefWord;
- // anonymous functions
- Procedure TestAnonymousProc_Assign_ObjFPC;
- Procedure TestAnonymousProc_Assign_Delphi;
- Procedure TestAnonymousProc_Arg;
- Procedure TestAnonymousProc_Typecast;
- Procedure TestAnonymousProc_With;
- Procedure TestAnonymousProc_ExceptOn;
- Procedure TestAnonymousProc_Nested;
- Procedure TestAnonymousProc_NestedAssignResult;
- Procedure TestAnonymousProc_Class;
- Procedure TestAnonymousProc_ForLoop;
- Procedure TestAnonymousProc_AsmDelphi;
- // enums, sets
- Procedure TestEnum_Name;
- Procedure TestEnum_Number;
- Procedure TestEnum_ConstFail;
- Procedure TestEnum_Functions;
- Procedure TestEnumRg_Functions;
- Procedure TestEnum_AsParams;
- Procedure TestEnumRange_Array;
- Procedure TestEnum_ForIn;
- Procedure TestEnum_ScopedNumber;
- Procedure TestEnum_InFunction;
- Procedure TestEnum_Name_Anonymous_Unit;
- Procedure TestSet_Enum;
- Procedure TestSet_Operators;
- Procedure TestSet_Operator_In;
- Procedure TestSet_Functions;
- Procedure TestSet_PassAsArgClone;
- Procedure TestSet_AsParams;
- Procedure TestSet_Property;
- Procedure TestSet_EnumConst;
- Procedure TestSet_IntConst;
- Procedure TestSet_IntRange;
- Procedure TestSet_AnonymousEnumType;
- Procedure TestSet_AnonymousEnumTypeChar; // ToDo
- Procedure TestSet_ConstEnum;
- Procedure TestSet_ConstChar;
- Procedure TestSet_ConstInt;
- Procedure TestSet_InFunction;
- Procedure TestSet_ForIn;
- // statements
- Procedure TestNestBegin;
- Procedure TestIncDec;
- Procedure TestLoHiFpcMode;
- Procedure TestLoHiDelphiMode;
- Procedure TestAssignments;
- Procedure TestArithmeticOperators1;
- Procedure TestMultiAdd;
- Procedure TestLogicalOperators;
- Procedure TestBitwiseOperators;
- Procedure TestBitwiseOperatorsLongword;
- Procedure TestFunctionInt;
- Procedure TestFunctionString;
- Procedure TestIfThen;
- Procedure TestForLoop;
- Procedure TestForLoopInsideFunction;
- Procedure TestForLoop_ReadVarAfter;
- Procedure TestForLoop_Nested;
- Procedure TestRepeatUntil;
- Procedure TestAsmBlock;
- Procedure TestAsmPas_Impl; // ToDo
- Procedure TestTryFinally;
- Procedure TestTryExcept;
- Procedure TestTryExcept_ReservedWords;
- Procedure TestIfThenRaiseElse;
- Procedure TestCaseOf;
- Procedure TestCaseOf_UseSwitch;
- Procedure TestCaseOfNoElse;
- Procedure TestCaseOfNoElse_UseSwitch;
- Procedure TestCaseOfRange;
- Procedure TestCaseOfString;
- Procedure TestCaseOfChar;
- Procedure TestCaseOfExternalClassConst;
- Procedure TestDebugger;
- // arrays
- Procedure TestArray_Dynamic;
- Procedure TestArray_Dynamic_Nil;
- Procedure TestArray_DynMultiDimensional;
- Procedure TestArray_DynamicAssign;
- Procedure TestArray_StaticInt;
- Procedure TestArray_StaticBool;
- Procedure TestArray_StaticChar;
- Procedure TestArray_StaticMultiDim;
- Procedure TestArray_StaticInFunction;
- Procedure TestArray_StaticMultiDimEqualNotImplemented;
- Procedure TestArrayOfRecord;
- Procedure TestArray_StaticRecord;
- Procedure TestArrayOfSet;
- Procedure TestArray_DynAsParam;
- Procedure TestArray_StaticAsParam;
- Procedure TestArrayElement_AsParams;
- Procedure TestArrayElementFromFuncResult_AsParams;
- Procedure TestArrayEnumTypeRange;
- Procedure TestArray_SetLengthOutArg;
- Procedure TestArray_SetLengthProperty;
- Procedure TestArray_SetLengthMultiDim;
- Procedure TestArray_SetLengthDynOfStatic;
- Procedure TestArray_OpenArrayOfString;
- Procedure TestArray_ArrayOfCharAssignString; // ToDo
- Procedure TestArray_ConstRef;
- Procedure TestArray_Concat;
- Procedure TestArray_Copy;
- Procedure TestArray_InsertDelete;
- Procedure TestArray_DynArrayConstObjFPC;
- Procedure TestArray_DynArrayConstDelphi;
- Procedure TestArray_ArrayLitAsParam;
- Procedure TestArray_ArrayLitMultiDimAsParam;
- Procedure TestArray_ArrayLitStaticAsParam;
- Procedure TestArray_ForInArrOfString;
- Procedure TestExternalClass_TypeCastArrayToExternalClass;
- Procedure TestExternalClass_TypeCastArrayFromExternalClass;
- Procedure TestArrayOfConst_TVarRec;
- Procedure TestArrayOfConst_PassBaseTypes;
- Procedure TestArrayOfConst_PassObj;
- // record
- Procedure TestRecord_Empty;
- Procedure TestRecord_Var;
- Procedure TestRecord_VarExternal;
- Procedure TestRecord_WithDo;
- Procedure TestRecord_Assign;
- Procedure TestRecord_AsParams;
- Procedure TestRecord_ConstRef;
- Procedure TestRecordElement_AsParams;
- Procedure TestRecordElementFromFuncResult_AsParams;
- Procedure TestRecordElementFromWith_AsParams;
- Procedure TestRecord_Equal;
- Procedure TestRecord_JSValue;
- Procedure TestRecord_VariantFail;
- Procedure TestRecord_FieldArray;
- Procedure TestRecord_Const;
- Procedure TestRecord_TypecastFail;
- Procedure TestRecord_InFunction;
- Procedure TestRecord_AnonymousFail;
- // advanced record
- Procedure TestAdvRecord_Function;
- Procedure TestAdvRecord_Property;
- Procedure TestAdvRecord_PropertyDefault;
- Procedure TestAdvRecord_Property_ClassMethod;
- Procedure TestAdvRecord_Const;
- Procedure TestAdvRecord_ExternalField;
- Procedure TestAdvRecord_SubRecord;
- Procedure TestAdvRecord_SubClass;
- Procedure TestAdvRecord_SubInterfaceFail;
- Procedure TestAdvRecord_Constructor;
- Procedure TestAdvRecord_ClassConstructor_Program;
- Procedure TestAdvRecord_ClassConstructor_Unit;
- // classes
- Procedure TestClass_TObjectDefaultConstructor;
- Procedure TestClass_TObjectConstructorWithParams;
- Procedure TestClass_TObjectConstructorWithDefaultParam;
- Procedure TestClass_Var;
- Procedure TestClass_Method;
- Procedure TestClass_Implementation;
- Procedure TestClass_Inheritance;
- Procedure TestClass_TypeAlias;
- Procedure TestClass_AbstractMethod;
- Procedure TestClass_CallInherited_ProcNoParams;
- Procedure TestClass_CallInherited_WithParams;
- Procedure TestClasS_CallInheritedConstructor;
- Procedure TestClass_ClassVar_Assign;
- Procedure TestClass_CallClassMethod;
- Procedure TestClass_CallClassMethodStatic; // ToDo
- Procedure TestClass_Property;
- Procedure TestClass_Property_ClassMethod;
- Procedure TestClass_Property_Indexed;
- Procedure TestClass_Property_IndexSpec;
- Procedure TestClass_PropertyOfTypeArray;
- Procedure TestClass_PropertyDefault;
- Procedure TestClass_PropertyDefault_TypecastToOtherDefault;
- //Procedure TestClass_PropertyDefault;
- Procedure TestClass_PropertyOverride;
- Procedure TestClass_PropertyIncVisibility;
- Procedure TestClass_Assigned;
- Procedure TestClass_WithClassDoCreate;
- Procedure TestClass_WithClassInstDoProperty;
- Procedure TestClass_WithClassInstDoPropertyWithParams;
- Procedure TestClass_WithClassInstDoFunc;
- Procedure TestClass_TypeCast;
- Procedure TestClass_TypeCastUntypedParam;
- Procedure TestClass_Overloads;
- Procedure TestClass_OverloadsAncestor;
- Procedure TestClass_OverloadConstructor;
- Procedure TestClass_OverloadDelphiOverride;
- Procedure TestClass_ReintroduceVarDelphi;
- Procedure TestClass_ReintroducedVar;
- Procedure TestClass_RaiseDescendant;
- Procedure TestClass_ExternalMethod;
- Procedure TestClass_ExternalVirtualNameMismatchFail;
- Procedure TestClass_ExternalOverrideFail;
- Procedure TestClass_ExternalVar;
- Procedure TestClass_Const;
- Procedure TestClass_ConstEnum;
- Procedure TestClass_LocalConstDuplicate_Prg;
- Procedure TestClass_LocalConstDuplicate_Unit;
- // ToDo: Procedure TestAdvRecord_LocalConstDuplicate;
- Procedure TestClass_LocalVarSelfFail;
- Procedure TestClass_ArgSelfFail;
- Procedure TestClass_NestedProcSelf;
- Procedure TestClass_NestedProcSelf2;
- Procedure TestClass_NestedProcClassSelf;
- Procedure TestClass_NestedProcCallInherited;
- Procedure TestClass_TObjectFree;
- Procedure TestClass_TObjectFree_VarArg;
- Procedure TestClass_TObjectFreeNewInstance;
- Procedure TestClass_TObjectFreeLowerCase;
- Procedure TestClass_TObjectFreeFunctionFail;
- Procedure TestClass_TObjectFreePropertyFail;
- Procedure TestClass_ForIn;
- Procedure TestClass_DispatchMessage;
- Procedure TestClass_Message_DuplicateIntFail;
- Procedure TestClass_DispatchMessage_WrongFieldNameFail;
- // class of
- Procedure TestClassOf_Create;
- Procedure TestClassOf_Call;
- Procedure TestClassOf_Assign;
- Procedure TestClassOf_Is;
- Procedure TestClassOf_Compare;
- Procedure TestClassOf_ClassVar;
- Procedure TestClassOf_ClassMethod;
- Procedure TestClassOf_ClassProperty;
- Procedure TestClassOf_ClassMethodSelf;
- Procedure TestClassOf_TypeCast;
- Procedure TestClassOf_ImplicitFunctionCall;
- Procedure TestClassOf_Const;
- // nested class
- Procedure TestNestedClass_Alias;
- Procedure TestNestedClass_Record;
- Procedure TestNestedClass_Class;
- // external class
- Procedure TestExternalClass_Var;
- Procedure TestExternalClass_Const;
- Procedure TestExternalClass_Dollar;
- Procedure TestExternalClass_DuplicateVarFail;
- Procedure TestExternalClass_Method;
- Procedure TestExternalClass_ClassMethod;
- Procedure TestExternalClass_ClassMethodStatic;
- Procedure TestExternalClass_FunctionResultInTypeCast;
- Procedure TestExternalClass_NonExternalOverride;
- Procedure TestExternalClass_OverloadHint;
- Procedure TestExternalClass_SameNamePublishedProperty;
- Procedure TestExternalClass_Property;
- Procedure TestExternalClass_PropertyDate;
- Procedure TestExternalClass_ClassProperty;
- Procedure TestExternalClass_ClassOf;
- Procedure TestExternalClass_ClassOtherUnit;
- Procedure TestExternalClass_Is;
- Procedure TestExternalClass_As;
- Procedure TestExternalClass_DestructorFail;
- Procedure TestExternalClass_New;
- Procedure TestExternalClass_ClassOf_New;
- Procedure TestExternalClass_FuncClassOf_New;
- Procedure TestExternalClass_New_PasClassFail;
- Procedure TestExternalClass_New_PasClassBracketsFail;
- Procedure TestExternalClass_NewExtName;
- Procedure TestExternalClass_Constructor;
- Procedure TestExternalClass_ConstructorBrackets;
- Procedure TestExternalClass_LocalConstSameName;
- Procedure TestExternalClass_ReintroduceOverload;
- Procedure TestExternalClass_Inherited;
- Procedure TestExternalClass_PascalAncestorFail;
- Procedure TestExternalClass_NewInstance;
- Procedure TestExternalClass_NewInstance_NonVirtualFail;
- Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail;
- Procedure TestExternalClass_NewInstance_SecondParamTyped_Fail;
- Procedure TestExternalClass_JSFunctionPasDescendant;
- Procedure TestExternalClass_PascalProperty;
- Procedure TestExternalClass_TypeCastToRootClass;
- Procedure TestExternalClass_TypeCastToJSObject;
- Procedure TestExternalClass_TypeCastStringToExternalString;
- Procedure TestExternalClass_TypeCastToJSFunction;
- Procedure TestExternalClass_TypeCastDelphiUnrelated;
- Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
- Procedure TestExternalClass_BracketAccessor;
- Procedure TestExternalClass_BracketAccessor_Call;
- Procedure TestExternalClass_BracketAccessor_2ParamsFail;
- Procedure TestExternalClass_BracketAccessor_ReadOnly;
- Procedure TestExternalClass_BracketAccessor_WriteOnly;
- Procedure TestExternalClass_BracketAccessor_MultiType;
- Procedure TestExternalClass_BracketAccessor_Index;
- Procedure TestExternalClass_ForInJSObject;
- Procedure TestExternalClass_ForInJSArray;
- Procedure TestExternalClass_IncompatibleArgDuplicateIdentifier;
- // class interfaces
- Procedure TestClassInterface_Corba;
- Procedure TestClassInterface_ProcExternalFail;
- Procedure TestClassInterface_Overloads;
- Procedure TestClassInterface_DuplicateGUIInIntfListFail;
- Procedure TestClassInterface_DuplicateGUIInAncestorFail;
- Procedure TestClassInterface_AncestorImpl;
- Procedure TestClassInterface_ImplReintroduce;
- Procedure TestClassInterface_MethodResolution;
- Procedure TestClassInterface_AncestorMoreInterfaces;
- Procedure TestClassInterface_MethodOverride;
- Procedure TestClassInterface_Corba_Delegation;
- Procedure TestClassInterface_Corba_DelegationStatic;
- Procedure TestClassInterface_Corba_Operators;
- Procedure TestClassInterface_Corba_Args;
- Procedure TestClassInterface_Corba_ForIn;
- Procedure TestClassInterface_COM_AssignVar;
- Procedure TestClassInterface_COM_AssignArg;
- Procedure TestClassInterface_COM_FunctionResult;
- Procedure TestClassInterface_COM_InheritedFuncResult;
- Procedure TestClassInterface_COM_IsAsTypeCasts;
- Procedure TestClassInterface_COM_PassAsArg;
- Procedure TestClassInterface_COM_PassToUntypedParam;
- Procedure TestClassInterface_COM_FunctionInExpr;
- Procedure TestClassInterface_COM_Property;
- Procedure TestClassInterface_COM_IntfProperty;
- Procedure TestClassInterface_COM_Delegation;
- Procedure TestClassInterface_COM_With;
- Procedure TestClassInterface_COM_ForIn;
- Procedure TestClassInterface_COM_ArrayOfIntfFail;
- Procedure TestClassInterface_COM_RecordIntfFail;
- Procedure TestClassInterface_COM_UnitInitialization;
- Procedure TestClassInterface_GUID;
- Procedure TestClassInterface_GUIDProperty;
- // helpers
- Procedure TestClassHelper_ClassVar;
- Procedure TestClassHelper_Method_AccessInstanceFields;
- Procedure TestClassHelper_Method_Call;
- Procedure TestClassHelper_Method_Nested_Call;
- Procedure TestClassHelper_ClassMethod_Call;
- Procedure TestClassHelper_ClassOf;
- Procedure TestClassHelper_MethodRefObjFPC;
- Procedure TestClassHelper_Constructor;
- Procedure TestClassHelper_InheritedObjFPC;
- Procedure TestClassHelper_Property;
- Procedure TestClassHelper_Property_Array;
- Procedure TestClassHelper_Property_Array_Default;
- Procedure TestClassHelper_Property_Array_DefaultDefault;
- Procedure TestClassHelper_ClassProperty;
- Procedure TestClassHelper_ClassPropertyStatic;
- Procedure TestClassHelper_ClassProperty_Array;
- Procedure TestClassHelper_ForIn;
- Procedure TestClassHelper_PassProperty;
- Procedure TestExtClassHelper_ClassVar;
- Procedure TestExtClassHelper_Method_Call;
- Procedure TestExtClassHelper_ClassMethod_MissingStatic;
- Procedure TestRecordHelper_ClassVar;
- Procedure TestRecordHelper_Method_Call;
- Procedure TestRecordHelper_Constructor;
- Procedure TestTypeHelper_ClassVar;
- Procedure TestTypeHelper_PassResultElement;
- Procedure TestTypeHelper_PassArgs;
- Procedure TestTypeHelper_PassVarConst;
- Procedure TestTypeHelper_PassFuncResult;
- Procedure TestTypeHelper_PassPropertyField;
- Procedure TestTypeHelper_PassPropertyGetter;
- Procedure TestTypeHelper_PassClassPropertyField;
- Procedure TestTypeHelper_PassClassPropertyGetterStatic;
- Procedure TestTypeHelper_PassClassPropertyGetterNonStatic;
- Procedure TestTypeHelper_Property;
- Procedure TestTypeHelper_Property_Array;
- Procedure TestTypeHelper_ClassProperty;
- Procedure TestTypeHelper_ClassProperty_Array;
- Procedure TestTypeHelper_ClassMethod;
- Procedure TestTypeHelper_ExtClassMethodFail;
- Procedure TestTypeHelper_Constructor;
- Procedure TestTypeHelper_Word;
- Procedure TestTypeHelper_Boolean;
- Procedure TestTypeHelper_WordBool;
- Procedure TestTypeHelper_Double;
- Procedure TestTypeHelper_NativeInt;
- Procedure TestTypeHelper_StringChar;
- Procedure TestTypeHelper_JSValue;
- Procedure TestTypeHelper_Array;
- Procedure TestTypeHelper_EnumType;
- Procedure TestTypeHelper_SetType;
- Procedure TestTypeHelper_InterfaceType;
- Procedure TestTypeHelper_NestedSelf;
- // proc types
- Procedure TestProcType;
- Procedure TestProcType_Arg;
- Procedure TestProcType_FunctionFPC;
- Procedure TestProcType_FunctionDelphi;
- Procedure TestProcType_ProcedureDelphi;
- Procedure TestProcType_AsParam;
- Procedure TestProcType_MethodFPC;
- Procedure TestProcType_MethodDelphi;
- Procedure TestProcType_PropertyFPC;
- Procedure TestProcType_PropertyDelphi;
- Procedure TestProcType_WithClassInstDoPropertyFPC;
- Procedure TestProcType_Nested;
- Procedure TestProcType_NestedOfObject;
- Procedure TestProcType_ReferenceToProc;
- Procedure TestProcType_ReferenceToMethod;
- Procedure TestProcType_Typecast;
- Procedure TestProcType_PassProcToUntyped;
- Procedure TestProcType_PassProcToArray;
- Procedure TestProcType_SafeCallObjFPC;
- Procedure TestProcType_SafeCallDelphi;
- // pointer
- Procedure TestPointer;
- Procedure TestPointer_Proc;
- Procedure TestPointer_AssignRecordFail;
- Procedure TestPointer_AssignStaticArrayFail;
- Procedure TestPointer_TypeCastJSValueToPointer;
- Procedure TestPointer_NonRecordFail;
- Procedure TestPointer_AnonymousArgTypeFail;
- Procedure TestPointer_AnonymousVarTypeFail;
- Procedure TestPointer_AnonymousResultTypeFail;
- Procedure TestPointer_AddrOperatorFail;
- Procedure TestPointer_ArrayParamsFail;
- Procedure TestPointer_PointerAddFail;
- Procedure TestPointer_IncPointerFail;
- Procedure TestPointer_Record;
- Procedure TestPointer_RecordArg;
- // jsvalue
- Procedure TestJSValue_AssignToJSValue;
- Procedure TestJSValue_TypeCastToBaseType;
- Procedure TestJSValue_TypecastToJSValue;
- Procedure TestJSValue_Equal;
- Procedure TestJSValue_If;
- Procedure TestJSValue_Not;
- Procedure TestJSValue_Enum;
- Procedure TestJSValue_ClassInstance;
- Procedure TestJSValue_ClassOf;
- Procedure TestJSValue_ArrayOfJSValue;
- Procedure TestJSValue_ArrayLit;
- Procedure TestJSValue_Params;
- Procedure TestJSValue_UntypedParam;
- Procedure TestJSValue_FuncResultType;
- Procedure TestJSValue_ProcType_Assign;
- Procedure TestJSValue_ProcType_Equal;
- Procedure TestJSValue_ProcType_Param;
- Procedure TestJSValue_AssignToPointerFail;
- Procedure TestJSValue_OverloadDouble;
- Procedure TestJSValue_OverloadNativeInt;
- Procedure TestJSValue_OverloadWord;
- Procedure TestJSValue_OverloadString;
- Procedure TestJSValue_OverloadChar;
- Procedure TestJSValue_OverloadPointer;
- Procedure TestJSValue_ForIn;
- // RTTI
- Procedure TestRTTI_IntRange;
- Procedure TestRTTI_Double;
- Procedure TestRTTI_ProcType;
- Procedure TestRTTI_ProcType_ArgFromOtherUnit;
- Procedure TestRTTI_EnumAndSetType;
- Procedure TestRTTI_EnumRange;
- Procedure TestRTTI_AnonymousEnumType;
- Procedure TestRTTI_StaticArray;
- Procedure TestRTTI_DynArray;
- Procedure TestRTTI_ArrayNestedAnonymous;
- Procedure TestRTTI_PublishedMethodOverloadFail;
- Procedure TestRTTI_PublishedMethodHideNoHint;
- Procedure TestRTTI_PublishedMethodExternalFail;
- Procedure TestRTTI_PublishedClassPropertyFail;
- Procedure TestRTTI_PublishedClassFieldFail;
- Procedure TestRTTI_PublishedFieldExternalFail;
- Procedure TestRTTI_Class_Field;
- Procedure TestRTTI_Class_Method;
- Procedure TestRTTI_Class_MethodArgFlags;
- Procedure TestRTTI_Class_Property;
- Procedure TestRTTI_Class_PropertyParams;
- Procedure TestRTTI_Class_OtherUnit_TypeAlias;
- Procedure TestRTTI_Class_OmitRTTI;
- Procedure TestRTTI_Class_Field_AnonymousArrayOfSelfClass;
- Procedure TestRTTI_IndexModifier;
- Procedure TestRTTI_StoredModifier;
- Procedure TestRTTI_DefaultValue;
- Procedure TestRTTI_DefaultValueSet;
- Procedure TestRTTI_DefaultValueRangeType;
- Procedure TestRTTI_DefaultValueInherit;
- Procedure TestRTTI_OverrideMethod;
- Procedure TestRTTI_ReintroduceMethod;
- Procedure TestRTTI_OverloadProperty;
- // ToDo: array argument
- Procedure TestRTTI_ClassForward;
- Procedure TestRTTI_ClassOf;
- Procedure TestRTTI_Record;
- Procedure TestRTTI_RecordAnonymousArray;
- Procedure TestRTTI_Record_ClassVarType;
- Procedure TestRTTI_LocalTypes;
- Procedure TestRTTI_TypeInfo_BaseTypes;
- Procedure TestRTTI_TypeInfo_Type_BaseTypes;
- Procedure TestRTTI_TypeInfo_LocalFail;
- Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
- Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
- Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
- Procedure TestRTTI_TypeInfo_FunctionClassType;
- Procedure TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
- Procedure TestRTTI_Interface_Corba;
- Procedure TestRTTI_Interface_COM;
- Procedure TestRTTI_ClassHelper;
- Procedure TestRTTI_ExternalClass;
- Procedure TestRTTI_Unit;
- // Resourcestring
- Procedure TestResourcestringProgram;
- Procedure TestResourcestringUnit;
- Procedure TestResourcestringImplementation;
- // Attributes
- Procedure TestAttributes_Members;
- Procedure TestAttributes_Types;
- Procedure TestAttributes_HelperConstructor_Fail;
- // Assertions, checks
- procedure TestAssert;
- procedure TestAssert_SysUtils;
- procedure TestObjectChecks;
- procedure TestOverflowChecks_Int;
- procedure TestRangeChecks_AssignInt;
- procedure TestRangeChecks_AssignIntRange;
- procedure TestRangeChecks_AssignEnum;
- procedure TestRangeChecks_AssignEnumRange;
- procedure TestRangeChecks_AssignChar;
- procedure TestRangeChecks_AssignCharRange;
- procedure TestRangeChecks_ArrayIndex;
- procedure TestRangeChecks_ArrayOfRecIndex;
- procedure TestRangeChecks_StringIndex;
- procedure TestRangeChecks_TypecastInt;
- procedure TestRangeChecks_TypeHelperInt;
- // Async/AWait
- Procedure TestAsync_Proc;
- Procedure TestAsync_CallResultIsPromise;
- Procedure TestAsync_ConstructorFail;
- Procedure TestAsync_PropertyGetterFail;
- Procedure TestAwait_NonPromiseWithTypeFail;
- Procedure TestAwait_AsyncCallTypeMismatch;
- Procedure TestAWait_OutsideAsyncFail;
- Procedure TestAWait_IntegerFail;
- Procedure TestAWait_ExternalClassPromise;
- Procedure TestAWait_JSValue;
- Procedure TestAWait_Result;
- Procedure TestAWait_ResultPromiseMissingTypeFail; // await(AsyncCallResultPromise) needs T
- Procedure TestAsync_AnonymousProc;
- Procedure TestAsync_ProcType;
- Procedure TestAsync_ProcTypeAsyncModMismatchFail;
- Procedure TestAsync_Inherited;
- Procedure TestAsync_ClassInterface;
- Procedure TestAsync_ClassInterface_AsyncMissmatchFail;
- end;
- function LinesToStr(Args: array of const): string;
- function ExtractFileUnitName(aFilename: string): string;
- function JSToStr(El: TJSElement): string;
- function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
- implementation
- function LinesToStr(Args: array of const): string;
- var
- s: String;
- i: Integer;
- begin
- s:='';
- for i:=Low(Args) to High(Args) do
- case Args[i].VType of
- vtChar: s += Args[i].VChar+LineEnding;
- vtString: s += Args[i].VString^+LineEnding;
- vtPChar: s += Args[i].VPChar+LineEnding;
- vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding;
- vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding;
- vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding;
- vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
- vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
- end;
- Result:=s;
- end;
- function ExtractFileUnitName(aFilename: string): string;
- var
- p: Integer;
- begin
- Result:=ExtractFileName(aFilename);
- if Result='' then exit;
- for p:=length(Result) downto 1 do
- case Result[p] of
- '/','\': exit;
- '.':
- begin
- Delete(Result,p,length(Result));
- exit;
- end;
- end;
- end;
- function JSToStr(El: TJSElement): string;
- var
- aWriter: TBufferWriter;
- aJSWriter: TJSWriter;
- begin
- aJSWriter:=nil;
- aWriter:=TBufferWriter.Create(1000);
- try
- aJSWriter:=TJSWriter.Create(aWriter);
- aJSWriter.IndentSize:=2;
- aJSWriter.WriteJS(El);
- Result:=aWriter.AsString;
- finally
- aJSWriter.Free;
- aWriter.Free;
- end;
- end;
- function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
- // search diff, ignore changes in spaces
- const
- SpaceChars = [#9,#10,#13,' '];
- var
- ExpectedP, ActualP: PChar;
- function FindLineEnd(p: PChar): PChar;
- begin
- Result:=p;
- while not (Result^ in [#0,#10,#13]) do inc(Result);
- end;
- function FindLineStart(p, MinP: PChar): PChar;
- begin
- while (p>MinP) and not (p[-1] in [#10,#13]) do dec(p);
- Result:=p;
- end;
- procedure SkipLineEnd(var p: PChar);
- begin
- if p^ in [#10,#13] then
- begin
- if (p[1] in [#10,#13]) and (p^<>p[1]) then
- inc(p,2)
- else
- inc(p);
- end;
- end;
- function HasSpecialChar(s: string): boolean;
- var
- i: Integer;
- begin
- for i:=1 to length(s) do
- if s[i] in [#0..#31,#127..#255] then
- exit(true);
- Result:=false;
- end;
- function HashSpecialChars(s: string): string;
- var
- i: Integer;
- begin
- Result:='';
- for i:=1 to length(s) do
- if s[i] in [#0..#31,#127..#255] then
- Result:=Result+'#'+hexstr(ord(s[i]),2)
- else
- Result:=Result+s[i];
- end;
- procedure DiffFound;
- var
- ActLineStartP, ActLineEndP, p, StartPos: PChar;
- ExpLine, ActLine: String;
- i, LineNo, DiffLineNo: Integer;
- begin
- writeln('Diff found "',Msg,'". Lines:');
- // write correct lines
- p:=PChar(Expected);
- LineNo:=0;
- DiffLineNo:=0;
- repeat
- StartPos:=p;
- while not (p^ in [#0,#10,#13]) do inc(p);
- ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
- SkipLineEnd(p);
- inc(LineNo);
- if (p<=ExpectedP) and (p^<>#0) then
- begin
- writeln('= ',ExpLine);
- end else begin
- // diff line
- if DiffLineNo=0 then DiffLineNo:=LineNo;
- // write actual line
- ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
- ActLineEndP:=FindLineEnd(ActualP);
- ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
- writeln('- ',ActLine);
- if HasSpecialChar(ActLine) then
- writeln('- ',HashSpecialChars(ActLine));
- // write expected line
- writeln('+ ',ExpLine);
- if HasSpecialChar(ExpLine) then
- writeln('- ',HashSpecialChars(ExpLine));
- // write empty line with pointer ^
- for i:=1 to 2+ExpectedP-StartPos do write(' ');
- writeln('^');
- Msg:='expected "'+ExpLine+'", but got "'+ActLine+'".';
- CheckSrcDiff:=false;
- // write up to three following actual lines to get some context
- for i:=1 to 3 do begin
- ActLineStartP:=ActLineEndP;
- SkipLineEnd(ActLineStartP);
- if ActLineStartP^=#0 then break;
- ActLineEndP:=FindLineEnd(ActLineStartP);
- ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
- writeln('~ ',ActLine);
- end;
- exit;
- end;
- until p^=#0;
- writeln('DiffFound Actual:-----------------------');
- writeln(Actual);
- writeln('DiffFound Expected:---------------------');
- writeln(Expected);
- writeln('DiffFound ------------------------------');
- Msg:='diff found, but lines are the same, internal error';
- CheckSrcDiff:=false;
- end;
- var
- IsSpaceNeeded: Boolean;
- LastChar, Quote: Char;
- begin
- Result:=true;
- Msg:='';
- if Expected='' then Expected:=' ';
- if Actual='' then Actual:=' ';
- ExpectedP:=PChar(Expected);
- ActualP:=PChar(Actual);
- repeat
- //writeln('TTestModule.CheckDiff Exp="',ExpectedP^,'" Act="',ActualP^,'"');
- case ExpectedP^ of
- #0:
- begin
- // check that rest of Actual has only spaces
- while ActualP^ in SpaceChars do inc(ActualP);
- if ActualP^<>#0 then
- begin
- DiffFound;
- exit;
- end;
- exit(true);
- end;
- ' ',#9,#10,#13:
- begin
- // skip space in Expected
- IsSpaceNeeded:=false;
- if ExpectedP>PChar(Expected) then
- LastChar:=ExpectedP[-1]
- else
- LastChar:=#0;
- while ExpectedP^ in SpaceChars do inc(ExpectedP);
- if (LastChar in ['a'..'z','A'..'Z','0'..'9','_','$'])
- and (ExpectedP^ in ['a'..'z','A'..'Z','0'..'9','_','$']) then
- IsSpaceNeeded:=true;
- if IsSpaceNeeded and (not (ActualP^ in SpaceChars)) then
- begin
- DiffFound;
- exit;
- end;
- while ActualP^ in SpaceChars do inc(ActualP);
- end;
- '''','"':
- begin
- while ActualP^ in SpaceChars do inc(ActualP);
- if ExpectedP^<>ActualP^ then
- begin
- DiffFound;
- exit;
- end;
- Quote:=ExpectedP^;
- repeat
- inc(ExpectedP);
- inc(ActualP);
- if ExpectedP^<>ActualP^ then
- begin
- DiffFound;
- exit;
- end;
- if (ExpectedP^ in [#0,#10,#13]) then
- break
- else if (ExpectedP^=Quote) then
- begin
- inc(ExpectedP);
- inc(ActualP);
- break;
- end;
- until false;
- end;
- else
- while ActualP^ in SpaceChars do inc(ActualP);
- if ExpectedP^<>ActualP^ then
- begin
- DiffFound;
- exit;
- end;
- inc(ExpectedP);
- inc(ActualP);
- end;
- until false;
- end;
- { TTestEnginePasResolver }
- destructor TTestEnginePasResolver.Destroy;
- begin
- FreeAndNil(FStreamResolver);
- FreeAndNil(FParser);
- FreeAndNil(FScanner);
- FreeAndNil(FStreamResolver);
- if Module<>nil then
- begin
- Module.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
- FModule:=nil;
- end;
- inherited Destroy;
- end;
- function TTestEnginePasResolver.FindUnit(const AName, InFilename: String;
- NameExpr, InFileExpr: TPasExpr): TPasModule;
- begin
- Result:=nil;
- if InFilename<>'' then
- RaiseNotYetImplemented(20180224101926,InFileExpr,'Use testcase tcunitsearch instead');
- if Assigned(OnFindUnit) then
- Result:=OnFindUnit(AName);
- if NameExpr=nil then ;
- end;
- procedure TTestEnginePasResolver.UsedInterfacesFinished(Section: TPasSection);
- begin
- // do not parse recursively
- // parse via the queue
- if Section=nil then ;
- end;
- { TCustomTestModule }
- function TCustomTestModule.GetMsgCount: integer;
- begin
- Result:=FHintMsgs.Count;
- end;
- function TCustomTestModule.GetMsgs(Index: integer): TTestHintMessage;
- begin
- Result:=TTestHintMessage(FHintMsgs[Index]);
- end;
- function TCustomTestModule.GetResolverCount: integer;
- begin
- Result:=FModules.Count;
- end;
- function TCustomTestModule.GetResolvers(Index: integer
- ): TTestEnginePasResolver;
- begin
- Result:=TTestEnginePasResolver(FModules[Index]);
- end;
- function TCustomTestModule.OnPasResolverFindUnit(const aUnitName: String
- ): TPasModule;
- var
- DefNamespace: String;
- begin
- //writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
- if (Pos('.',aUnitName)<1) then
- begin
- DefNamespace:=GetDefaultNamespace;
- if DefNamespace<>'' then
- begin
- Result:=LoadUnit(DefNamespace+'.'+aUnitName);
- if Result<>nil then exit;
- end;
- end;
- Result:=LoadUnit(aUnitName);
- if Result<>nil then exit;
- {$IFDEF VerbosePas2JS}
- writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
- {$ENDIF}
- Fail('can''t find unit "'+aUnitName+'"');
- end;
- procedure TCustomTestModule.OnParserLog(Sender: TObject; const Msg: String);
- var
- aParser: TPasParser;
- Item: TTestHintMessage;
- begin
- aParser:=Sender as TPasParser;
- Item:=TTestHintMessage.Create;
- Item.Id:=aParser.LastMsgNumber;
- Item.MsgType:=aParser.LastMsgType;
- Item.MsgNumber:=aParser.LastMsgNumber;
- Item.Msg:=Msg;
- Item.SourcePos:=aParser.Scanner.CurSourcePos;
- {$IFDEF VerbosePas2JS}
- writeln('TCustomTestModule.OnParserLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
- {$ENDIF}
- FHintMsgs.Add(Item);
- end;
- procedure TCustomTestModule.OnPasResolverLog(Sender: TObject; const Msg: String
- );
- var
- aResolver: TTestEnginePasResolver;
- Item: TTestHintMessage;
- begin
- aResolver:=Sender as TTestEnginePasResolver;
- Item:=TTestHintMessage.Create;
- Item.Id:=aResolver.LastMsgId;
- Item.MsgType:=aResolver.LastMsgType;
- Item.MsgNumber:=aResolver.LastMsgNumber;
- Item.Msg:=Msg;
- Item.SourcePos:=aResolver.LastSourcePos;
- {$IFDEF VerbosePas2JS}
- writeln('TCustomTestModule.OnPasResolverLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
- {$ENDIF}
- FHintMsgs.Add(Item);
- end;
- procedure TCustomTestModule.OnScannerLog(Sender: TObject; const Msg: String);
- var
- Item: TTestHintMessage;
- aScanner: TPas2jsPasScanner;
- begin
- aScanner:=Sender as TPas2jsPasScanner;
- Item:=TTestHintMessage.Create;
- Item.Id:=aScanner.LastMsgNumber;
- Item.MsgType:=aScanner.LastMsgType;
- Item.MsgNumber:=aScanner.LastMsgNumber;
- Item.Msg:=Msg;
- Item.SourcePos:=aScanner.CurSourcePos;
- {$IFDEF VerbosePas2JS}
- writeln('TCustomTestModule.OnScannerLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
- {$ENDIF}
- FHintMsgs.Add(Item);
- end;
- procedure TCustomTestModule.SetWithTypeInfo(const AValue: boolean);
- begin
- if FWithTypeInfo=AValue then Exit;
- FWithTypeInfo:=AValue;
- if AValue then
- Converter.Options:=Converter.Options-[coNoTypeInfo]
- else
- Converter.Options:=Converter.Options+[coNoTypeInfo];
- end;
- function TCustomTestModule.LoadUnit(const aUnitName: String): TPasModule;
- var
- i: Integer;
- CurEngine: TTestEnginePasResolver;
- CurUnitName: String;
- begin
- //writeln('TTestModule.FindUnit START Unit="',aUnitName,'"');
- Result:=nil;
- if (Module.ClassType=TPasModule)
- and (CompareText(Module.Name,aUnitName)=0) then
- exit(Module);
- for i:=0 to ResolverCount-1 do
- begin
- CurEngine:=Resolvers[i];
- CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
- //writeln('TTestModule.FindUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
- if CompareText(aUnitName,CurUnitName)=0 then
- begin
- Result:=CurEngine.Module;
- if Result<>nil then exit;
- //writeln('TTestModule.FindUnit PARSING unit "',CurEngine.Filename,'"');
- FileResolver.FindSourceFile(aUnitName);
- CurEngine.StreamResolver:=TStreamResolver.Create;
- CurEngine.StreamResolver.OwnsStreams:=True;
- //writeln('TTestModule.FindUnit SOURCE=',CurEngine.Source);
- CurEngine.StreamResolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
- CurEngine.Scanner:=TPas2jsPasScanner.Create(CurEngine.StreamResolver);
- InitScanner(CurEngine.Scanner);
- CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.StreamResolver,CurEngine);
- CurEngine.Parser.Options:=po_tcmodules;
- if CompareText(CurUnitName,'System')=0 then
- CurEngine.Parser.ImplicitUses.Clear;
- CurEngine.Scanner.OpenFile(CurEngine.Filename);
- try
- CurEngine.Parser.NextToken;
- CurEngine.Parser.ParseUnit(CurEngine.FModule);
- except
- on E: Exception do
- HandleException(E);
- end;
- //writeln('TTestModule.FindUnit END ',CurUnitName);
- Result:=CurEngine.Module;
- exit;
- end;
- end;
- end;
- procedure TCustomTestModule.SetUp;
- begin
- {$IFDEF EnablePasTreeGlobalRefCount}
- FElementRefCountAtSetup:=TPasElement.GlobalRefCount;
- {$ENDIF}
- if FModules<>nil then
- begin
- writeln('TCustomTestModule.SetUp FModules<>nil');
- Halt;
- end;
- inherited SetUp;
- FSkipTests:=false;
- FWithTypeInfo:=false;
- FSource:=TStringList.Create;
- FHub:=TPas2JSResolverHub.Create(Self);
- FModules:=TObjectList.Create(true);
- FFilename:='test1.pp';
- FFileResolver:=TStreamResolver.Create;
- FFileResolver.OwnsStreams:=True;
- FScanner:=TPas2jsPasScanner.Create(FFileResolver);
- InitScanner(FScanner);
- FEngine:=AddModule(Filename);
- FEngine.Scanner:=FScanner;
- FScanner.Resolver:=FEngine;
- FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
- FParser.OnLog:=@OnParserLog;
- FEngine.Parser:=FParser;
- Parser.Options:=po_tcmodules;
- FModule:=Nil;
- FConverter:=CreateConverter;
- FExpectedErrorClass:=nil;
- end;
- function TCustomTestModule.CreateConverter: TPasToJSConverter;
- var
- Options: TPasToJsConverterOptions;
- begin
- Result:=TPasToJSConverter.Create;
- Options:=co_tcmodules;
- if WithTypeInfo then
- Exclude(Options,coNoTypeInfo)
- else
- Include(Options,coNoTypeInfo);
- Result.Options:=Options;
- Result.Globals:=TPasToJSConverterGlobals.Create(Result);
- end;
- procedure TCustomTestModule.InitScanner(aScanner: TPas2jsPasScanner);
- begin
- aScanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
- aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
- aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
- aScanner.AllowedBoolSwitches:=bsAllPas2jsBoolSwitches;
- aScanner.ReadOnlyBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly;
- aScanner.CurrentBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
- aScanner.AllowedValueSwitches:=vsAllPas2jsValueSwitches;
- aScanner.ReadOnlyValueSwitches:=vsAllPas2jsValueSwitchesReadOnly;
- aScanner.OnLog:=@OnScannerLog;
- aScanner.CompilerVersion:='Comp.Ver.tcmodules';
- end;
- procedure TCustomTestModule.TearDown;
- {$IFDEF CheckPasTreeRefCount}
- var
- El: TPasElement;
- {$ENDIF}
- var
- i: Integer;
- CurModule: TPasModule;
- begin
- FHintMsgs.Clear;
- FHintMsgsGood.Clear;
- FSkipTests:=false;
- FWithTypeInfo:=false;
- FJSRegModuleCall:=nil;
- FJSModuleCallArgs:=nil;
- FJSImplentationUses:=nil;
- FJSInterfaceUses:=nil;
- FJSModuleSrc:=nil;
- FJSInitBody:=nil;
- FreeAndNil(FJSSource);
- FreeAndNil(FJSModule);
- FreeAndNil(FConverter);
- Engine.Clear;
- FreeAndNil(FSource);
- FreeAndNil(FFileResolver);
- if FModules<>nil then
- begin
- for i:=0 to FModules.Count-1 do
- begin
- CurModule:=TTestEnginePasResolver(FModules[i]).Module;
- if CurModule=nil then continue;
- //writeln('TCustomTestModule.TearDown ReleaseUsedUnits ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
- CurModule.ReleaseUsedUnits;
- end;
- if FModule<>nil then
- FModule.ReleaseUsedUnits;
- for i:=0 to FModules.Count-1 do
- begin
- CurModule:=TTestEnginePasResolver(FModules[i]).Module;
- if CurModule=nil then continue;
- //writeln('TCustomTestModule.TearDown UsesReleased ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
- end;
- FreeAndNil(FModules);
- ReleaseAndNil(TPasElement(FModule){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
- FEngine:=nil;
- end;
- FreeAndNil(FHub);
- inherited TearDown;
- {$IFDEF EnablePasTreeGlobalRefCount}
- if FElementRefCountAtSetup<>TPasElement.GlobalRefCount then
- begin
- writeln('TCustomTestModule.TearDown GlobalRefCount Was='+IntToStr(FElementRefCountAtSetup)+' Now='+IntToStr(TPasElement.GlobalRefCount));
- {$IFDEF CheckPasTreeRefCount}
- El:=TPasElement.FirstRefEl;
- while El<>nil do
- begin
- writeln(' ',GetObjName(El),' RefIds.Count=',El.RefIds.Count,':');
- for i:=0 to El.RefIds.Count-1 do
- writeln(' ',El.RefIds[i]);
- El:=El.NextRefEl;
- end;
- {$ENDIF}
- Halt;
- Fail('TCustomTestModule.TearDown Was='+IntToStr(FElementRefCountAtSetup)+' Now='+IntToStr(TPasElement.GlobalRefCount));
- end;
- {$ENDIF}
- end;
- procedure TCustomTestModule.Add(Line: string);
- begin
- Source.Add(Line);
- end;
- procedure TCustomTestModule.Add(const Lines: array of string);
- var
- i: Integer;
- begin
- for i:=low(Lines) to high(Lines) do
- Add(Lines[i]);
- end;
- procedure TCustomTestModule.StartParsing;
- var
- Src: String;
- begin
- Src:=Source.Text;
- FEngine.Source:=Src;
- FileResolver.AddStream(FileName,TStringStream.Create(Src));
- Scanner.OpenFile(FileName);
- Writeln('// Test : ',Self.TestName);
- Writeln(Src);
- end;
- procedure TCustomTestModule.ParseModuleQueue;
- var
- i: Integer;
- CurResolver: TTestEnginePasResolver;
- Found: Boolean;
- Section: TPasSection;
- begin
- // parse til exception or all modules finished
- while not SkipTests do
- begin
- Found:=false;
- for i:=0 to ResolverCount-1 do
- begin
- CurResolver:=Resolvers[i];
- if CurResolver.CurrentParser=nil then continue;
- if not CurResolver.CurrentParser.CanParseContinue(Section) then
- continue;
- CurResolver.Parser.ParseContinue;
- Found:=true;
- break;
- end;
- if not Found then break;
- end;
- for i:=0 to ResolverCount-1 do
- begin
- CurResolver:=Resolvers[i];
- if CurResolver.Parser=nil then
- begin
- if CurResolver.CurrentParser<>nil then
- Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' '+GetObjName(CurResolver.Parser)+'=Parser<>CurrentParser='+GetObjName(CurResolver.CurrentParser));
- continue;
- end;
- if CurResolver.Parser.CurModule<>nil then
- Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' NOT FINISHED CurModule='+GetObjName(CurResolver.Parser.CurModule));
- end;
- end;
- procedure TCustomTestModule.ParseModule;
- begin
- if SkipTests then exit;
- FFirstPasStatement:=nil;
- try
- StartParsing;
- Parser.ParseMain(FModule);
- ParseModuleQueue;
- except
- on E: Exception do
- HandleException(E);
- end;
- if SkipTests then exit;
- AssertNotNull('Module resulted in Module',Module);
- AssertEquals('modulename',lowercase(ChangeFileExt(FFileName,'')),lowercase(Module.Name));
- TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
- end;
- procedure TCustomTestModule.ParseProgram;
- begin
- if SkipTests then exit;
- ParseModule;
- if SkipTests then exit;
- AssertEquals('Has program',TPasProgram,Module.ClassType);
- FPasProgram:=TPasProgram(Module);
- AssertNotNull('Has program section',PasProgram.ProgramSection);
- AssertNotNull('Has initialization section',PasProgram.InitializationSection);
- if (PasProgram.InitializationSection.Elements.Count>0) then
- if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
- FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
- end;
- procedure TCustomTestModule.ParseUnit;
- begin
- if SkipTests then exit;
- ParseModule;
- if SkipTests then exit;
- AssertEquals('Has unit (TPasModule)',TPasModule,Module.ClassType);
- AssertNotNull('Has interface section',Module.InterfaceSection);
- AssertNotNull('Has implementation section',Module.ImplementationSection);
- if (Module.InitializationSection<>nil)
- and (Module.InitializationSection.Elements.Count>0)
- and (TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock) then
- FFirstPasStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
- end;
- function TCustomTestModule.FindModuleWithFilename(aFilename: string
- ): TTestEnginePasResolver;
- var
- i: Integer;
- begin
- for i:=0 to ResolverCount-1 do
- if CompareText(Resolvers[i].Filename,aFilename)=0 then
- exit(Resolvers[i]);
- Result:=nil;
- end;
- function TCustomTestModule.AddModule(aFilename: string
- ): TTestEnginePasResolver;
- begin
- //writeln('TTestModuleConverter.AddModule ',aFilename);
- if FindModuleWithFilename(aFilename)<>nil then
- Fail('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
- Result:=TTestEnginePasResolver.Create;
- Result.Filename:=aFilename;
- Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
- Result.OnFindUnit:=@OnPasResolverFindUnit;
- Result.OnLog:=@OnPasResolverLog;
- Result.Hub:=Hub;
- FModules.Add(Result);
- end;
- function TCustomTestModule.AddModuleWithSrc(aFilename, Src: string
- ): TTestEnginePasResolver;
- begin
- Result:=AddModule(aFilename);
- Result.Source:=Src;
- end;
- function TCustomTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
- ImplementationSrc: string): TTestEnginePasResolver;
- var
- Src: String;
- begin
- Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
- Src+=LineEnding;
- Src+='interface'+LineEnding;
- Src+=LineEnding;
- Src+=InterfaceSrc;
- Src+='implementation'+LineEnding;
- Src+=LineEnding;
- Src+=ImplementationSrc;
- Src+='end.'+LineEnding;
- Result:=AddModuleWithSrc(aFilename,Src);
- end;
- procedure TCustomTestModule.AddSystemUnit(Parts: TSystemUnitParts);
- var
- Intf, Impl: TStringList;
- begin
- Intf:=TStringList.Create;
- if supTInterfacedObject in Parts then Include(Parts,supTObject);
- // unit interface
- if [supTVarRec,supTypeInfo]*Parts<>[] then
- Intf.Add('{$modeswitch externalclass}');
- Intf.Add('type');
- Intf.Add(' integer=longint;');
- Intf.Add(' sizeint=nativeint;');
- //'const',
- //' LineEnding = #10;',
- //' DirectorySeparator = ''/'';',
- //' DriveSeparator = '''';',
- //' AllowDirectorySeparators : set of char = [''\'',''/''];',
- //' AllowDriveSeparators : set of char = [];',
- if supTObject in Parts then
- Intf.AddStrings([
- 'type',
- ' TClass = class of TObject;',
- ' TObject = class',
- ' constructor Create;',
- ' destructor Destroy; virtual;',
- ' class function ClassType: TClass; assembler;',
- ' class function ClassName: String; assembler;',
- ' class function ClassNameIs(const Name: string): boolean;',
- ' class function ClassParent: TClass; assembler;',
- ' class function InheritsFrom(aClass: TClass): boolean; assembler;',
- ' class function UnitName: String; assembler;',
- ' procedure AfterConstruction; virtual;',
- ' procedure BeforeDestruction;virtual;',
- ' function Equals(Obj: TObject): boolean; virtual;',
- ' function ToString: String; virtual;',
- ' end;']);
- if supTInterfacedObject in Parts then
- Intf.AddStrings([
- ' {$Interfaces COM}',
- ' IUnknown = interface',
- ' [''{00000000-0000-0000-C000-000000000046}'']',
- //' function QueryInterface(const iid: TGuid; out obj): Integer;',
- ' function _AddRef: Integer;',
- ' function _Release: Integer;',
- ' end;',
- ' IInterface = IUnknown;',
- ' TInterfacedObject = class(TObject,IUnknown)',
- ' protected',
- ' fRefCount: Integer;',
- ' { implement methods of IUnknown }',
- //' function QueryInterface(const iid: TGuid; out obj): Integer; virtual;',
- ' function _AddRef: Integer; virtual;',
- ' function _Release: Integer; virtual;',
- ' end;',
- ' TInterfacedClass = class of TInterfacedObject;',
- '',
- '']);
- if supTVarRec in Parts then
- Intf.AddStrings([
- 'const',
- ' vtInteger = 0;',
- ' vtBoolean = 1;',
- ' vtJSValue = 19;',
- 'type',
- ' PVarRec = ^TVarRec;',
- ' TVarRec = record',
- ' VType : byte;',
- ' VJSValue: JSValue;',
- ' vInteger: longint external name ''VJSValue'';',
- ' vBoolean: boolean external name ''VJSValue'';',
- ' end;',
- ' TVarRecArray = array of TVarRec;',
- 'function VarRecs: TVarRecArray; varargs;',
- '']);
- if supTypeInfo in Parts then
- begin
- Intf.AddStrings([
- 'type',
- ' TTypeKind = (',
- ' tkUnknown, // 0',
- ' tkInteger, // 1',
- ' tkChar, // 2 in Delphi/FPC tkWChar, tkUChar',
- ' tkString, // 3 in Delphi/FPC tkSString, tkWString or tkUString',
- ' tkEnumeration, // 4',
- ' tkSet, // 5',
- ' tkDouble, // 6',
- ' tkBool, // 7',
- ' tkProcVar, // 8 function or procedure',
- ' tkMethod, // 9 proc var of object',
- ' tkArray, // 10 static array',
- ' tkDynArray, // 11',
- ' tkRecord, // 12',
- ' tkClass, // 13',
- ' tkClassRef, // 14',
- ' tkPointer, // 15',
- ' tkJSValue, // 16',
- ' tkRefToProcVar, // 17 variable of procedure type',
- ' tkInterface, // 18',
- ' //tkObject,',
- ' //tkSString,tkLString,tkAString,tkWString,',
- ' //tkVariant,',
- ' //tkWChar,',
- ' //tkInt64,',
- ' //tkQWord,',
- ' //tkInterfaceRaw,',
- ' //tkUString,tkUChar,',
- ' tkHelper, // 19',
- ' //tkFile,',
- ' tkExtClass // 20',
- ' );',
- ' TTypeKinds = set of TTypeKind;',
- ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
- ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)',
- ' end;',
- ' TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;',
- ' TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;',
- ' TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;',
- ' TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;',
- ' TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;',
- ' TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;',
- ' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
- ' TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;',
- ' TTypeInfoExtClass = class external name ''rtl.tTypeInfoExtClass''(TTypeInfo) end;',
- ' TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;',
- ' TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;',
- ' TTypeInfoHelper = class external name ''rtl.tTypeInfoHelper''(TTypeInfo) end;',
- ' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
- '']);
- end;
- if supWriteln in Parts then
- Intf.Add('procedure writeln; varargs; external name ''console.log'';');
- Intf.Add('var');
- Intf.Add(' ExitCode: Longint = 0;');
- // unit implementation
- Impl:=TStringList.Create;
- if supTObject in Parts then
- Impl.AddStrings([
- '// needed by ClassNameIs, the real SameText is in SysUtils',
- 'function SameText(const s1, s2: String): Boolean; assembler;',
- 'asm',
- 'end;',
- 'constructor TObject.Create; begin end;',
- 'destructor TObject.Destroy; begin end;',
- 'class function TObject.ClassType: TClass; assembler;',
- 'asm',
- 'end;',
- 'class function TObject.ClassName: String; assembler;',
- 'asm',
- 'end;',
- 'class function TObject.ClassNameIs(const Name: string): boolean;',
- 'begin',
- ' Result:=SameText(Name,ClassName);',
- 'end;',
- 'class function TObject.ClassParent: TClass; assembler;',
- 'asm',
- 'end;',
- 'class function TObject.InheritsFrom(aClass: TClass): boolean; assembler;',
- 'asm',
- 'end;',
- 'class function TObject.UnitName: String; assembler;',
- 'asm',
- 'end;',
- 'procedure TObject.AfterConstruction; begin end;',
- 'procedure TObject.BeforeDestruction; begin end;',
- 'function TObject.Equals(Obj: TObject): boolean;',
- 'begin',
- ' Result:=Obj=Self;',
- 'end;',
- 'function TObject.ToString: String;',
- 'begin',
- ' Result:=ClassName;',
- 'end;'
- ]);
- if supTInterfacedObject in Parts then
- Impl.AddStrings([
- //'function TInterfacedObject.QueryInterface(const iid: TGuid; out obj): Integer;',
- //'begin',
- //'end;',
- 'function TInterfacedObject._AddRef: Integer;',
- 'begin',
- 'end;',
- 'function TInterfacedObject._Release: Integer;',
- 'begin',
- 'end;',
- '']);
- if supTVarRec in Parts then
- Impl.AddStrings([
- 'function VarRecs: TVarRecArray; varargs;',
- 'var',
- ' v: PVarRec;',
- 'begin',
- ' v^.VType:=1;',
- ' v^.VJSValue:=2;',
- 'end;',
- '']);
- try
- AddModuleWithIntfImplSrc('system.pp',Intf.Text,Impl.Text);
- finally
- Intf.Free;
- Impl.Free;
- end;
- end;
- procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean;
- SystemUnitParts: TSystemUnitParts);
- begin
- if NeedSystemUnit then
- AddSystemUnit(SystemUnitParts)
- else
- Parser.ImplicitUses.Clear;
- Add('program '+ExtractFileUnitName(Filename)+';');
- Add('');
- end;
- procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean;
- SystemUnitParts: TSystemUnitParts);
- begin
- if NeedSystemUnit then
- AddSystemUnit(SystemUnitParts)
- else
- Parser.ImplicitUses.Clear;
- Add('unit Test1;');
- Add('');
- end;
- procedure TCustomTestModule.ConvertModule;
- procedure CheckUsesList(UsesName: String; Arg: TJSArrayLiteralElement;
- out UsesLit: TJSArrayLiteral);
- var
- i: Integer;
- Item: TJSElement;
- Lit: TJSLiteral;
- begin
- UsesLit:=nil;
- AssertNotNull(UsesName+' uses section',Arg.Expr);
- if (Arg.Expr.ClassType=TJSLiteral) and TJSLiteral(Arg.Expr).Value.IsNull then
- exit; // null is ok
- AssertEquals(UsesName+' uses section param is array',TJSArrayLiteral,Arg.Expr.ClassType);
- FJSInterfaceUses:=TJSArrayLiteral(Arg.Expr);
- for i:=0 to FJSInterfaceUses.Elements.Count-1 do
- begin
- Item:=FJSInterfaceUses.Elements.Elements[i].Expr;
- AssertNotNull(UsesName+' uses section item['+IntToStr(i)+'].Expr',Item);
- AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is lit',TJSLiteral,Item.ClassType);
- Lit:=TJSLiteral(Item);
- AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is string lit',
- ord(jsbase.jstString),ord(Lit.Value.ValueType));
- end;
- end;
- procedure CheckFunctionParam(ParamName: string; Arg: TJSArrayLiteralElement;
- out Src: TJSSourceElements);
- var
- FunDecl: TJSFunctionDeclarationStatement;
- FunDef: TJSFuncDef;
- FunBody: TJSFunctionBody;
- begin
- Src:=nil;
- AssertNotNull(ParamName,Arg.Expr);
- AssertEquals(ParamName+' Arg.Expr type',TJSFunctionDeclarationStatement,Arg.Expr.ClassType);
- FunDecl:=Arg.Expr as TJSFunctionDeclarationStatement;
- AssertNotNull(ParamName+' FunDecl.AFunction',FunDecl.AFunction);
- AssertEquals(ParamName+' FunDecl.AFunction type',TJSFuncDef,FunDecl.AFunction.ClassType);
- FunDef:=FunDecl.AFunction as TJSFuncDef;
- AssertEquals(ParamName+' name empty','',String(FunDef.Name));
- AssertNotNull(ParamName+' body',FunDef.Body);
- AssertEquals(ParamName+' body type',TJSFunctionBody,FunDef.Body.ClassType);
- FunBody:=FunDef.Body as TJSFunctionBody;
- AssertNotNull(ParamName+' body.A',FunBody.A);
- AssertEquals(ParamName+' body.A type',TJSSourceElements,FunBody.A.ClassType);
- Src:=FunBody.A as TJSSourceElements;
- end;
- var
- ModuleNameExpr: TJSLiteral;
- InitFunction: TJSFunctionDeclarationStatement;
- InitAssign: TJSSimpleAssignStatement;
- InitName: String;
- LastNode: TJSElement;
- Arg: TJSArrayLiteralElement;
- begin
- if SkipTests then exit;
- try
- FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements;
- except
- on E: Exception do
- HandleException(E);
- end;
- if SkipTests then exit;
- if ExpectedErrorClass<>nil then
- Fail('Missing '+ExpectedErrorClass.ClassName+' error {'+ExpectedErrorMsg+'} ('+IntToStr(ExpectedErrorNumber)+')');
- FJSSource:=TStringList.Create;
- FJSSource.Text:=ConvertJSModuleToString(JSModule);
- {$IFDEF VerbosePas2JS}
- writeln('TTestModule.ConvertModule JS:');
- write(FJSSource.Text);
- {$ENDIF}
- // rtl.module(...
- AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
- AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
- AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
- FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
- AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
- AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
- AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
- FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
- // parameter 'unitname'
- if JSModuleCallArgs.Elements.Count<1 then
- Fail('rtl.module first param unit missing');
- Arg:=JSModuleCallArgs.Elements.Elements[0];
- AssertNotNull('module name param',Arg.Expr);
- ModuleNameExpr:=Arg.Expr as TJSLiteral;
- AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
- if Module is TPasProgram then
- AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
- else
- AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
- // main uses section
- if JSModuleCallArgs.Elements.Count<2 then
- Fail('rtl.module second param main uses missing');
- Arg:=JSModuleCallArgs.Elements.Elements[1];
- CheckUsesList('interface',Arg,FJSInterfaceUses);
- // program/library/interface function()
- if JSModuleCallArgs.Elements.Count<3 then
- Fail('rtl.module third param intf-function missing');
- Arg:=JSModuleCallArgs.Elements.Elements[2];
- CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
- // search for $mod.$init or $mod.$main - the last statement
- if Module is TPasProgram then
- begin
- InitName:='$main';
- AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
- end
- else
- InitName:='$init';
- FJSInitBody:=nil;
- if JSModuleSrc.Statements.Count>0 then
- begin
- LastNode:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node;
- if LastNode is TJSSimpleAssignStatement then
- begin
- InitAssign:=LastNode as TJSSimpleAssignStatement;
- if GetDottedIdentifier(InitAssign.LHS)='$mod.'+InitName then
- begin
- InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
- FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
- end
- else if Module is TPasProgram then
- CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
- end;
- end;
- // optional: implementation uses section
- if JSModuleCallArgs.Elements.Count<4 then
- exit;
- Arg:=JSModuleCallArgs.Elements.Elements[3];
- CheckUsesList('implementation',Arg,FJSImplentationUses);
- end;
- procedure TCustomTestModule.ConvertProgram;
- begin
- Add('end.');
- ParseProgram;
- ConvertModule;
- end;
- procedure TCustomTestModule.ConvertUnit;
- begin
- Add('end.');
- ParseUnit;
- ConvertModule;
- end;
- function TCustomTestModule.ConvertJSModuleToString(El: TJSElement): string;
- begin
- Result:=tcmodules.JSToStr(El);
- end;
- procedure TCustomTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
- DottedName: string);
- begin
- if DottedName='' then
- begin
- AssertNull(Msg,El);
- end
- else
- begin
- AssertNotNull(Msg,El);
- AssertEquals(Msg,DottedName,GetDottedIdentifier(El));
- end;
- end;
- function TCustomTestModule.GetDottedIdentifier(El: TJSElement): string;
- begin
- if El=nil then
- Result:=''
- else if El is TJSPrimaryExpressionIdent then
- Result:=String(TJSPrimaryExpressionIdent(El).Name)
- else if El is TJSDotMemberExpression then
- Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
- else
- AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
- end;
- procedure TCustomTestModule.CheckSource(Msg, Statements: String;
- InitStatements: string; ImplStatements: string);
- var
- ActualSrc, ExpectedSrc, InitName: String;
- begin
- ActualSrc:=JSToStr(JSModuleSrc);
- if coUseStrict in Converter.Options then
- ExpectedSrc:='"use strict";'+LineEnding
- else
- ExpectedSrc:='';
- ExpectedSrc:=ExpectedSrc+'var $mod = this;'+LineEnding;
- ExpectedSrc:=ExpectedSrc+Statements;
- // unit implementation
- if (Trim(ImplStatements)<>'') then
- ExpectedSrc:=ExpectedSrc+LineEnding
- +'$mod.$implcode = function () {'+LineEnding
- +ImplStatements
- +'};'+LineEnding;
- // program main or unit initialization
- if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
- begin
- if Module is TPasProgram then
- InitName:='$main'
- else
- InitName:='$init';
- ExpectedSrc:=ExpectedSrc+LineEnding
- +'$mod.'+InitName+' = function () {'+LineEnding
- +InitStatements
- +'};'+LineEnding;
- end;
- //writeln('TCustomTestModule.CheckSource ExpectedIntf="',ExpectedSrc,'"');
- //writeln('TTestModule.CheckSource InitStatements="',Trim(InitStatements),'"');
- CheckDiff(Msg,ExpectedSrc,ActualSrc);
- end;
- procedure TCustomTestModule.CheckDiff(Msg, Expected, Actual: string);
- // search diff, ignore changes in spaces
- var
- s: string;
- begin
- if CheckSrcDiff(Expected,Actual,s) then exit;
- Fail(Msg+': '+s);
- end;
- procedure TCustomTestModule.CheckUnit(Filename, ExpectedSrc: string);
- var
- aResolver: TTestEnginePasResolver;
- aConverter: TPasToJSConverter;
- aJSModule: TJSSourceElements;
- ActualSrc: String;
- begin
- aResolver:=GetResolver(Filename);
- AssertNotNull('missing resolver of unit '+Filename,aResolver);
- AssertNotNull('missing resolver.module of unit '+Filename,aResolver.Module);
- {$IFDEF VerbosePas2JS}
- writeln('CheckUnit '+Filename+' converting ...');
- {$ENDIF}
- aConverter:=CreateConverter;
- aJSModule:=nil;
- try
- try
- aJSModule:=aConverter.ConvertPasElement(aResolver.Module,aResolver) as TJSSourceElements;
- except
- on E: Exception do
- HandleException(E);
- end;
- ActualSrc:=ConvertJSModuleToString(aJSModule);
- {$IFDEF VerbosePas2JS}
- writeln('TTestModule.CheckUnit ',Filename,' Pas:');
- write(aResolver.Source);
- writeln('TTestModule.CheckUnit ',Filename,' JS:');
- write(ActualSrc);
- {$ENDIF}
- CheckDiff('Converted unit: "'+ChangeFileExt(Filename,'.js')+'"',ExpectedSrc,ActualSrc);
- finally
- aJSModule.Free;
- aConverter.Free;
- end;
- end;
- procedure TCustomTestModule.CheckHint(MsgType: TMessageType;
- MsgNumber: integer; Msg: string; Marker: PSrcMarker);
- var
- i: Integer;
- Item: TTestHintMessage;
- Expected,Actual: string;
- begin
- //writeln('TCustomTestModule.CheckHint MsgCount=',MsgCount);
- for i:=0 to MsgCount-1 do
- begin
- Item:=Msgs[i];
- if (Item.MsgNumber<>MsgNumber) or (Item.Msg<>Msg) then continue;
- if (Marker<>nil) then
- begin
- if Item.SourcePos.Row<>cardinal(Marker^.Row) then continue;
- if (Item.SourcePos.Column<cardinal(Marker^.StartCol))
- or (Item.SourcePos.Column>cardinal(Marker^.EndCol)) then continue;
- end;
- // found
- FHintMsgsGood.Add(Item);
- str(Item.MsgType,Actual);
- str(MsgType,Expected);
- AssertEquals('MsgType',Expected,Actual);
- exit;
- end;
- // needed message missing -> show emitted messages
- WriteSources('',0,0);
- for i:=0 to MsgCount-1 do
- begin
- Item:=Msgs[i];
- write('TCustomTestModule.CheckHint ',i,'/',MsgCount,' ',Item.MsgType,
- ' ('+IntToStr(Item.MsgNumber),')');
- if Marker<>nil then
- write(' '+ExtractFileName(Item.SourcePos.FileName),'(',Item.SourcePos.Row,',',Item.SourcePos.Column,')');
- writeln(' {',Item.Msg,'}');
- end;
- str(MsgType,Expected);
- Actual:='Missing '+Expected+' ('+IntToStr(MsgNumber)+')';
- if Marker<>nil then
- Actual:=Actual+' '+ExtractFileName(Marker^.Filename)+'('+IntToStr(Marker^.Row)+','+IntToStr(Marker^.StartCol)+'..'+IntToStr(Marker^.EndCol)+')';
- Actual:=Actual+' '+Msg;
- Fail(Actual);
- end;
- procedure TCustomTestModule.CheckResolverUnexpectedHints(WithSourcePos: boolean
- );
- var
- i: Integer;
- s, Txt: String;
- Msg: TTestHintMessage;
- begin
- for i:=0 to MsgCount-1 do
- begin
- Msg:=Msgs[i];
- if FHintMsgsGood.IndexOf(Msg)>=0 then continue;
- s:='';
- str(Msg.MsgType,s);
- Txt:='Unexpected resolver message found ['+IntToStr(Msg.Id)+'] '
- +s+': ('+IntToStr(Msg.MsgNumber)+')';
- if WithSourcePos then
- Txt:=Txt+' '+ExtractFileName(Msg.SourcePos.FileName)+'('+IntToStr(Msg.SourcePos.Row)+','+IntToStr(Msg.SourcePos.Column)+')';
- Txt:=Txt+' {'+Msg.Msg+'}';
- Fail(Txt);
- end;
- end;
- procedure TCustomTestModule.SetExpectedScannerError(Msg: string;
- MsgNumber: integer);
- begin
- ExpectedErrorClass:=EScannerError;
- ExpectedErrorMsg:=Msg;
- ExpectedErrorNumber:=MsgNumber;
- end;
- procedure TCustomTestModule.SetExpectedParserError(Msg: string;
- MsgNumber: integer);
- begin
- ExpectedErrorClass:=EParserError;
- ExpectedErrorMsg:=Msg;
- ExpectedErrorNumber:=MsgNumber;
- end;
- procedure TCustomTestModule.SetExpectedPasResolverError(Msg: string;
- MsgNumber: integer);
- begin
- ExpectedErrorClass:=EPasResolve;
- ExpectedErrorMsg:=Msg;
- ExpectedErrorNumber:=MsgNumber;
- end;
- procedure TCustomTestModule.SetExpectedConverterError(Msg: string;
- MsgNumber: integer);
- begin
- ExpectedErrorClass:=EPas2JS;
- ExpectedErrorMsg:=Msg;
- ExpectedErrorNumber:=MsgNumber;
- end;
- function TCustomTestModule.IsErrorExpected(E: Exception): boolean;
- var
- MsgNumber: Integer;
- Msg: String;
- begin
- Result:=false;
- if (ExpectedErrorClass=nil) or (ExpectedErrorClass<>E.ClassType) then exit;
- Msg:=E.Message;
- if E is EPas2JS then
- MsgNumber:=EPas2JS(E).MsgNumber
- else if E is EPasResolve then
- MsgNumber:=EPasResolve(E).MsgNumber
- else if E is EParserError then
- MsgNumber:=Parser.LastMsgNumber
- else if E is EScannerError then
- begin
- MsgNumber:=Scanner.LastMsgNumber;
- Msg:=Scanner.LastMsg;
- end
- else
- MsgNumber:=0;
- Result:=(MsgNumber=ExpectedErrorNumber) and (Msg=ExpectedErrorMsg);
- if Result then
- SkipTests:=true;
- end;
- procedure TCustomTestModule.HandleScannerError(E: EScannerError);
- begin
- if IsErrorExpected(E) then exit;
- WriteSources(Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn);
- writeln('ERROR: TCustomTestModule.HandleScannerError '+E.ClassName+':'+E.Message
- +' '+Scanner.CurFilename
- +'('+IntToStr(Scanner.CurRow)+','+IntToStr(Scanner.CurColumn)+')');
- FailException(E);
- end;
- procedure TCustomTestModule.HandleParserError(E: EParserError);
- begin
- if IsErrorExpected(E) then exit;
- WriteSources(E.Filename,E.Row,E.Column);
- writeln('ERROR: TCustomTestModule.HandleParserError '+E.ClassName+':'+E.Message
- +' '+E.Filename+'('+IntToStr(E.Row)+','+IntToStr(E.Column)+')'
- +' MainModuleScannerLine="'+Scanner.CurLine+'"'
- );
- FailException(E);
- end;
- procedure TCustomTestModule.HandlePasResolveError(E: EPasResolve);
- var
- P: TPasSourcePos;
- begin
- if IsErrorExpected(E) then exit;
- P:=E.SourcePos;
- WriteSources(P.FileName,P.Row,P.Column);
- writeln('ERROR: TCustomTestModule.HandlePasResolveError '+E.ClassName+':'+E.Message
- +' '+P.FileName+'('+IntToStr(P.Row)+','+IntToStr(P.Column)+')');
- FailException(E);
- end;
- procedure TCustomTestModule.HandlePas2JSError(E: EPas2JS);
- var
- Row, Col: integer;
- begin
- if IsErrorExpected(E) then exit;
- Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col);
- WriteSources(E.PasElement.SourceFilename,Row,Col);
- writeln('ERROR: TCustomTestModule.HandlePas2JSError '+E.ClassName+':'+E.Message
- +' '+E.PasElement.SourceFilename
- +'('+IntToStr(Row)+','+IntToStr(Col)+')');
- FailException(E);
- end;
- procedure TCustomTestModule.HandleException(E: Exception);
- begin
- if E is EScannerError then
- HandleScannerError(EScannerError(E))
- else if E is EParserError then
- HandleParserError(EParserError(E))
- else if E is EPasResolve then
- HandlePasResolveError(EPasResolve(E))
- else if E is EPas2JS then
- HandlePas2JSError(EPas2JS(E))
- else
- begin
- if IsErrorExpected(E) then exit;
- if not (E is EAssertionFailedError) then
- begin
- WriteSources('',0,0);
- writeln('ERROR: TCustomTestModule.HandleException '+E.ClassName+':'+E.Message);
- end;
- FailException(E);
- end;
- end;
- procedure TCustomTestModule.FailException(E: Exception);
- var
- MsgNumber: Integer;
- begin
- if ExpectedErrorClass<>nil then
- begin
- if FExpectedErrorClass=E.ClassType then
- begin
- if E is EPas2JS then
- MsgNumber:=EPas2JS(E).MsgNumber
- else if E is EPasResolve then
- MsgNumber:=EPasResolve(E).MsgNumber
- else if E is EParserError then
- MsgNumber:=Parser.LastMsgNumber
- else if E is EScannerError then
- MsgNumber:=Scanner.LastMsgNumber
- else
- MsgNumber:=0;
- AssertEquals('Expected error message ('+IntToStr(ExpectedErrorNumber)+')','{'+ExpectedErrorMsg+'}','{'+E.Message+'}');
- AssertEquals('Expected {'+ExpectedErrorMsg+'}, but got msg {'+E.Message+'} number',
- ExpectedErrorNumber,MsgNumber);
- end else begin
- AssertEquals('Wrong exception class',ExpectedErrorClass.ClassName,E.ClassName);
- end;
- end;
- Fail(E.Message);
- end;
- procedure TCustomTestModule.WriteSources(const aFilename: string; aRow,
- aCol: integer);
- var
- IsSrc: Boolean;
- i, j: Integer;
- SrcLines: TStringList;
- Line: string;
- aModule: TTestEnginePasResolver;
- begin
- writeln('TCustomTestModule.WriteSources File="',aFilename,'" Row=',aRow,' Col=',aCol);
- for i:=0 to ResolverCount-1 do
- begin
- aModule:=Resolvers[i];
- SrcLines:=TStringList.Create;
- try
- SrcLines.Text:=aModule.Source;
- IsSrc:=ExtractFilename(aModule.Filename)=ExtractFileName(aFilename);
- writeln('Testcode:-File="',aModule.Filename,'"----------------------------------:');
- for j:=1 to SrcLines.Count do
- begin
- Line:=SrcLines[j-1];
- if IsSrc and (j=aRow) then
- begin
- write('*');
- Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line));
- end;
- writeln(Format('%:4d: ',[j]),Line);
- end;
- finally
- SrcLines.Free;
- end;
- end;
- end;
- function TCustomTestModule.IndexOfResolver(const Filename: string): integer;
- var
- i: Integer;
- begin
- for i:=0 to ResolverCount-1 do
- if Filename=Resolvers[i].Filename then exit(i);
- Result:=-1;
- end;
- function TCustomTestModule.GetResolver(const Filename: string
- ): TTestEnginePasResolver;
- var
- i: Integer;
- begin
- i:=IndexOfResolver(Filename);
- if i<0 then exit(nil);
- Result:=Resolvers[i];
- end;
- function TCustomTestModule.GetDefaultNamespace: string;
- var
- C: TClass;
- begin
- Result:='';
- if FModule=nil then exit;
- C:=FModule.ClassType;
- if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
- Result:=Engine.DefaultNameSpace;
- end;
- constructor TCustomTestModule.Create;
- begin
- inherited Create;
- FHintMsgs:=TObjectList.Create(true);
- FHintMsgsGood:=TFPList.Create;
- end;
- destructor TCustomTestModule.Destroy;
- begin
- FreeAndNil(FHintMsgs);
- FreeAndNil(FHintMsgsGood);
- inherited Destroy;
- end;
- { TTestModule }
- procedure TTestModule.TestReservedWords;
- var
- i: integer;
- begin
- for i:=low(JSReservedWords) to High(JSReservedWords)-1 do
- if CompareStr(JSReservedWords[i],JSReservedWords[i+1])>=0 then
- Fail('20170203135442 '+JSReservedWords[i]+' >= '+JSReservedWords[i+1]);
- for i:=low(JSReservedGlobalWords) to High(JSReservedGlobalWords)-1 do
- if CompareStr(JSReservedGlobalWords[i],JSReservedGlobalWords[i+1])>=0 then
- Fail('20170203135443 '+JSReservedGlobalWords[i]+' >= '+JSReservedGlobalWords[i+1]);
- end;
- procedure TTestModule.TestEmptyProgram;
- begin
- StartProgram(false);
- Add('begin');
- ConvertProgram;
- CheckSource('TestEmptyProgram','','');
- end;
- procedure TTestModule.TestEmptyProgramUseStrict;
- begin
- Converter.Options:=Converter.Options+[coUseStrict];
- StartProgram(false);
- Add('begin');
- ConvertProgram;
- CheckSource('TestEmptyProgramUseStrict','','');
- end;
- procedure TTestModule.TestEmptyUnit;
- begin
- StartUnit(false);
- Add('interface');
- Add('implementation');
- ConvertUnit;
- CheckSource('TestEmptyUnit',
- LinesToStr([
- ]),
- '');
- end;
- procedure TTestModule.TestEmptyUnitUseStrict;
- begin
- Converter.Options:=Converter.Options+[coUseStrict];
- StartUnit(false);
- Add('interface');
- Add('implementation');
- ConvertUnit;
- CheckSource('TestEmptyUnitUseStrict',
- LinesToStr([
- ''
- ]),
- '');
- end;
- procedure TTestModule.TestDottedUnitNames;
- begin
- AddModuleWithIntfImplSrc('NS1.Unit2.pas',
- LinesToStr([
- 'var iV: longint;'
- ]),
- '');
- FFilename:='ns1.test1.pp';
- StartProgram(true);
- Add('uses unIt2;');
- Add('var');
- Add(' i: longint;');
- Add('begin');
- Add(' i:=iv;');
- Add(' i:=uNit2.iv;');
- Add(' i:=Ns1.TEst1.i;');
- ConvertProgram;
- CheckSource('TestDottedUnitNames',
- LinesToStr([
- 'this.i = 0;',
- '']),
- LinesToStr([ // this.$init
- '$mod.i = pas["NS1.Unit2"].iV;',
- '$mod.i = pas["NS1.Unit2"].iV;',
- '$mod.i = $mod.i;',
- '']) );
- end;
- procedure TTestModule.TestDottedUnitNameImpl;
- begin
- AddModuleWithIntfImplSrc('TEST.UnitA.pas',
- LinesToStr([
- 'type',
- ' TObject = class end;',
- ' TTestA = class',
- ' end;'
- ]),
- LinesToStr(['uses TEST.UnitB;'])
- );
- AddModuleWithIntfImplSrc('TEST.UnitB.pas',
- LinesToStr([
- 'uses TEST.UnitA;',
- 'type TTestB = class(TTestA);'
- ]),
- ''
- );
- StartProgram(true);
- Add('uses TEST.UnitA;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestDottedUnitNameImpl',
- LinesToStr([
- '']),
- LinesToStr([ // this.$init
- '']) );
- CheckUnit('TEST.UnitA.pas',
- LinesToStr([
- 'rtl.module("TEST.UnitA", ["system"], function () {',
- ' var $mod = this;',
- ' rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' });',
- ' rtl.createClass(this, "TTestA", this.TObject, function () {',
- ' });',
- '}, ["TEST.UnitB"]);'
- ]));
- CheckUnit('TEST.UnitB.pas',
- LinesToStr([
- 'rtl.module("TEST.UnitB", ["system","TEST.UnitA"], function () {',
- ' var $mod = this;',
- ' rtl.createClass(this, "TTestB", pas["TEST.UnitA"].TTestA, function () {',
- ' });',
- '});'
- ]));
- end;
- procedure TTestModule.TestDottedUnitExpr;
- begin
- AddModuleWithIntfImplSrc('NS2.SubNs2.Unit2.pas',
- LinesToStr([
- 'procedure DoIt;'
- ]),
- 'procedure DoIt; begin end;');
- FFilename:='Ns1.SubNs1.Test1.pp';
- StartProgram(true);
- Add('uses Ns2.sUbnS2.unIt2;');
- Add('var');
- Add(' i: longint;');
- Add('begin');
- Add(' ns2.subns2.unit2.doit;');
- Add(' i:=Ns1.SubNS1.TEst1.i;');
- ConvertProgram;
- CheckSource('TestDottedUnitExpr',
- LinesToStr([
- 'this.i = 0;',
- '']),
- LinesToStr([ // this.$init
- 'pas["NS2.SubNs2.Unit2"].DoIt();',
- '$mod.i = $mod.i;',
- '']) );
- end;
- procedure TTestModule.Test_ModeFPCFail;
- begin
- StartProgram(false);
- Add('{$mode FPC}');
- Add('begin');
- SetExpectedScannerError('Invalid mode: "FPC"',nErrInvalidMode);
- ConvertProgram;
- end;
- procedure TTestModule.Test_ModeSwitchCBlocksFail;
- begin
- StartProgram(false);
- Add('{$modeswitch cblocks-}');
- Add('begin');
- ConvertProgram;
- CheckHint(mtWarning,nErrInvalidModeSwitch,'Warning: test1.pp(3,23) : Invalid mode switch: "cblocks"');
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestUnit_UseSystem;
- begin
- StartUnit(true);
- Add([
- 'interface',
- 'var i: integer;',
- 'implementation']);
- ConvertUnit;
- CheckSource('TestUnit_UseSystem',
- LinesToStr([
- 'this.i = 0;',
- '']),
- LinesToStr([
- '']) );
- end;
- procedure TTestModule.TestUnit_Intf1Impl2Intf1;
- begin
- AddModuleWithIntfImplSrc('unit1.pp',
- LinesToStr([
- 'type number = longint;']),
- LinesToStr([
- 'uses test1;',
- 'procedure DoIt;',
- 'begin',
- ' i:=3;',
- 'end;']));
- StartUnit(true);
- Add([
- 'interface',
- 'uses unit1;',
- 'var i: number;',
- 'implementation']);
- ConvertUnit;
- CheckSource('TestUnit_Intf1Impl2Intf1',
- LinesToStr([
- 'this.i = 0;',
- '']),
- LinesToStr([
- '']) );
- end;
- procedure TTestModule.TestIncludeVersion;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' s: string;',
- ' i: word;',
- 'begin',
- ' s:={$I %line%};',
- ' i:={$I %linenum%};',
- ' s:={$I %currentroutine%};',
- ' s:={$I %pas2jsversion%};',
- ' s:={$I %pas2jstarget%};',
- ' s:={$I %pas2jstargetos%};',
- ' s:={$I %pas2jstargetcpu%};',
- ' s:={$I %file%};',
- '']);
- ConvertProgram;
- CheckSource('TestIncludeVersion',
- LinesToStr([
- 'this.s="";',
- 'this.i = 0;']),
- LinesToStr([
- '$mod.s = "7";',
- '$mod.i = 8;',
- '$mod.s = "<anonymous>";',
- '$mod.s = "Comp.Ver.tcmodules";',
- '$mod.s = "Browser";',
- '$mod.s = "Browser";',
- '$mod.s = "ECMAScript5";',
- '$mod.s = "test1.pp";',
- '']));
- end;
- procedure TTestModule.TestVarInt;
- begin
- StartProgram(false);
- Add('var MyI: longint;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestVarInt','this.MyI=0;','');
- end;
- procedure TTestModule.TestVarBaseTypes;
- begin
- StartProgram(false);
- Add('var');
- Add(' i: longint;');
- Add(' s: string;');
- Add(' c: char;');
- Add(' b: boolean;');
- Add(' d: double;');
- Add(' i2: longint = 3;');
- Add(' s2: string = ''foo'';');
- Add(' c2: char = ''4'';');
- Add(' b2: boolean = true;');
- Add(' d2: double = 5.6;');
- Add(' i3: longint = $707;');
- Add(' i4: nativeint = 9007199254740991;');
- Add(' i5: nativeint = -9007199254740991-1;');
- Add(' i6: nativeint = $fffffffffffff;');
- Add(' i7: nativeint = -$fffffffffffff-1;');
- Add(' i8: byte = 00;');
- Add(' u8: nativeuint = $fffffffffffff;');
- Add(' u9: nativeuint = $0000000000000;');
- Add(' u10: nativeuint = $00ff00;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestVarBaseTypes',
- LinesToStr([
- 'this.i = 0;',
- 'this.s = "";',
- 'this.c = "";',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.i2 = 3;',
- 'this.s2 = "foo";',
- 'this.c2 = "4";',
- 'this.b2 = true;',
- 'this.d2 = 5.6;',
- 'this.i3 = 0x707;',
- 'this.i4 = 9007199254740991;',
- 'this.i5 = -9007199254740991-1;',
- 'this.i6 = 0xfffffffffffff;',
- 'this.i7 =-0xfffffffffffff-1;',
- 'this.i8 = 0;',
- 'this.u8 = 0xfffffffffffff;',
- 'this.u9 = 0x0;',
- 'this.u10 = 0xff00;'
- ]),
- '');
- end;
- procedure TTestModule.TestBaseTypeSingleFail;
- begin
- StartProgram(false);
- Add('var s: single;');
- SetExpectedPasResolverError('identifier not found "single"',PasResolveEval.nIdentifierNotFound);
- ConvertProgram;
- end;
- procedure TTestModule.TestBaseTypeExtendedFail;
- begin
- StartProgram(false);
- Add('var e: extended;');
- SetExpectedPasResolverError('identifier not found "extended"',PasResolveEval.nIdentifierNotFound);
- ConvertProgram;
- end;
- procedure TTestModule.TestConstBaseTypes;
- begin
- StartProgram(false);
- Add('const');
- Add(' i: longint = 3;');
- Add(' s: string = ''foo'';');
- Add(' c: char = ''4'';');
- Add(' b: boolean = true;');
- Add(' d: double = 5.6;');
- Add(' e = low(word);');
- Add(' f = high(word);');
- Add('begin');
- ConvertProgram;
- CheckSource('TestVarBaseTypes',
- LinesToStr([
- 'this.i=3;',
- 'this.s="foo";',
- 'this.c="4";',
- 'this.b=true;',
- 'this.d=5.6;',
- 'this.e = 0;',
- 'this.f = 65535;'
- ]),
- '');
- end;
- procedure TTestModule.TestAliasTypeRef;
- begin
- StartProgram(false);
- Add('type');
- Add(' a=longint;');
- Add(' b=a;');
- Add('var');
- Add(' c: A;');
- Add(' d: B;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestAliasTypeRef',
- LinesToStr([ // statements
- 'this.c = 0;',
- 'this.d = 0;'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestTypeCast_BaseTypes;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' i: longint;',
- ' b: boolean;',
- ' d: double;',
- ' s: string;',
- ' c: char;',
- 'begin',
- ' i:=longint(i);',
- ' i:=longint(b);',
- ' b:=boolean(b);',
- ' b:=boolean(i);',
- ' d:=double(d);',
- ' d:=double(i);',
- ' s:=string(s);',
- ' s:=string(c);',
- ' c:=char(c);',
- ' c:=char(i);',
- ' c:=char(65);',
- ' c:=char(#10);',
- ' c:=char(#$E000);',
- '']);
- ConvertProgram;
- CheckSource('TestAliasTypeRef',
- LinesToStr([ // statements
- 'this.i = 0;',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.s = "";',
- 'this.c = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.i = $mod.i;',
- '$mod.i = ($mod.b ? 1 : 0);',
- '$mod.b = $mod.b;',
- '$mod.b = $mod.i != 0;',
- '$mod.d = $mod.d;',
- '$mod.d = $mod.i;',
- '$mod.s = $mod.s;',
- '$mod.s = $mod.c;',
- '$mod.c = $mod.c;',
- '$mod.c = String.fromCharCode($mod.i);',
- '$mod.c = "A";',
- '$mod.c = "\n";',
- '$mod.c = "";',
- '']));
- end;
- procedure TTestModule.TestTypeCast_AliasBaseTypes;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TYesNo = boolean;');
- Add(' TFloat = double;');
- Add(' TCaption = string;');
- Add(' TChar = char;');
- Add('var');
- Add(' i: integer;');
- Add(' b: TYesNo;');
- Add(' d: TFloat;');
- Add(' s: TCaption;');
- Add(' c: TChar;');
- Add('begin');
- Add(' i:=integer(i);');
- Add(' i:=integer(b);');
- Add(' b:=TYesNo(b);');
- Add(' b:=TYesNo(i);');
- Add(' d:=TFloat(d);');
- Add(' d:=TFloat(i);');
- Add(' s:=TCaption(s);');
- Add(' s:=TCaption(c);');
- Add(' c:=TChar(c);');
- ConvertProgram;
- CheckSource('TestAliasTypeRef',
- LinesToStr([ // statements
- 'this.i = 0;',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.s = "";',
- 'this.c = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.i = $mod.i;',
- '$mod.i = ($mod.b ? 1 : 0);',
- '$mod.b = $mod.b;',
- '$mod.b = $mod.i != 0;',
- '$mod.d = $mod.d;',
- '$mod.d = $mod.i;',
- '$mod.s = $mod.s;',
- '$mod.s = $mod.c;',
- '$mod.c = $mod.c;',
- '']));
- end;
- procedure TTestModule.TestEmptyProc;
- begin
- StartProgram(false);
- Add('procedure Test;');
- Add('begin');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestEmptyProc',
- LinesToStr([ // statements
- 'this.Test = function () {',
- '};'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestProcOneParam;
- begin
- StartProgram(false);
- Add('procedure ProcA(i: longint);');
- Add('begin');
- Add('end;');
- Add('begin');
- Add(' PROCA(3);');
- ConvertProgram;
- CheckSource('TestProcOneParam',
- LinesToStr([ // statements
- 'this.ProcA = function (i) {',
- '};'
- ]),
- LinesToStr([ // this.$main
- '$mod.ProcA(3);'
- ]));
- end;
- procedure TTestModule.TestFunctionWithoutParams;
- begin
- StartProgram(false);
- Add('function FuncA: longint;');
- Add('begin');
- Add('end;');
- Add('var i: longint;');
- Add('begin');
- Add(' I:=FUNCA();');
- Add(' I:=FUNCA;');
- Add(' FUNCA();');
- Add(' FUNCA;');
- ConvertProgram;
- CheckSource('TestProcWithoutParams',
- LinesToStr([ // statements
- 'this.FuncA = function () {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.i=0;'
- ]),
- LinesToStr([ // this.$main
- '$mod.i=$mod.FuncA();',
- '$mod.i=$mod.FuncA();',
- '$mod.FuncA();',
- '$mod.FuncA();'
- ]));
- end;
- procedure TTestModule.TestProcedureWithoutParams;
- begin
- StartProgram(false);
- Add('procedure ProcA;');
- Add('begin');
- Add('end;');
- Add('begin');
- Add(' PROCA();');
- Add(' PROCA;');
- ConvertProgram;
- CheckSource('TestProcWithoutParams',
- LinesToStr([ // statements
- 'this.ProcA = function () {',
- '};'
- ]),
- LinesToStr([ // this.$main
- '$mod.ProcA();',
- '$mod.ProcA();'
- ]));
- end;
- procedure TTestModule.TestIncDec;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt(var i: longint);',
- 'begin',
- ' inc(i);',
- ' inc(i,2);',
- 'end;',
- 'var',
- ' Bar: longint;',
- 'begin',
- ' inc(bar);',
- ' inc(bar,2);',
- ' dec(bar);',
- ' dec(bar,3);',
- '']);
- ConvertProgram;
- CheckSource('TestIncDec',
- LinesToStr([ // statements
- 'this.DoIt = function (i) {',
- ' i.set(i.get()+1);',
- ' i.set(i.get()+2);',
- '};',
- 'this.Bar = 0;'
- ]),
- LinesToStr([ // this.$main
- '$mod.Bar+=1;',
- '$mod.Bar+=2;',
- '$mod.Bar-=1;',
- '$mod.Bar-=3;'
- ]));
- end;
- procedure TTestModule.TestLoHiFpcMode;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- 'const',
- ' LoByte1 = Lo(Word($1234));',
- ' HiByte1 = Hi(Word($1234));',
- ' LoByte2 = Lo(SmallInt($1234));',
- ' HiByte2 = Hi(SmallInt($1234));',
- ' LoWord1 = Lo($1234CDEF);',
- ' HiWord1 = Hi($1234CDEF);',
- ' LoWord2 = Lo(-$1234CDEF);',
- ' HiWord2 = Hi(-$1234CDEF);',
- ' lo4:byte=lo(byte($34));',
- ' hi4:byte=hi(byte($34));',
- ' lo5:byte=lo(shortint(-$34));',
- ' hi5:byte=hi(shortint(-$34));',
- ' lo6:longword=lo($123456789ABCD);',
- ' hi6:longword=hi($123456789ABCD);',
- ' lo7:longword=lo(-$123456789ABCD);',
- ' hi7:longword=hi(-$123456789ABCD);',
- 'var',
- ' b: Byte;',
- ' ss: shortint;',
- ' w: Word;',
- ' si: SmallInt;',
- ' lw: LongWord;',
- ' li: LongInt;',
- ' b2: Byte;',
- ' ni: nativeint;',
- 'begin',
- ' w := $1234;',
- ' ss := -$12;',
- ' b := lo(ss);',
- ' b := HI(ss);',
- ' b := lo(w);',
- ' b := HI(w);',
- ' b2 := lo(b);',
- ' b2 := hi(b);',
- ' lw := $1234CDEF;',
- ' w := lo(lw);',
- ' w := hi(lw);',
- ' ni := $123456789ABCD;',
- ' lw := lo(ni);',
- ' lw := hi(ni);',
- '']);
- ConvertProgram;
- CheckSource('TestLoHiFpcMode',
- LinesToStr([ // statements
- 'this.LoByte1 = 0x1234 & 0xFF;',
- 'this.HiByte1 = (0x1234 >> 8) & 0xFF;',
- 'this.LoByte2 = 0x1234 & 0xFF;',
- 'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
- 'this.LoWord1 = 0x1234CDEF & 0xFFFF;',
- 'this.HiWord1 = (0x1234CDEF >> 16) & 0xFFFF;',
- 'this.LoWord2 = -0x1234CDEF & 0xFFFF;',
- 'this.HiWord2 = (-0x1234CDEF >> 16) & 0xFFFF;',
- 'this.lo4 = 0x34 & 0xF;',
- 'this.hi4 = (0x34 >> 4) & 0xF;',
- 'this.lo5 = (((-0x34 & 255) << 24) >> 24) & 0xFF;',
- 'this.hi5 = ((((-0x34 & 255) << 24) >> 24) >> 8) & 0xFF;',
- 'this.lo6 = 0x123456789ABCD >>> 0;',
- 'this.hi6 = 74565 >>> 0;',
- 'this.lo7 = -0x123456789ABCD >>> 0;',
- 'this.hi7 = Math.floor(-0x123456789ABCD / 4294967296) >>> 0;',
- 'this.b = 0;',
- 'this.ss = 0;',
- 'this.w = 0;',
- 'this.si = 0;',
- 'this.lw = 0;',
- 'this.li = 0;',
- 'this.b2 = 0;',
- 'this.ni = 0;',
- '']),
- LinesToStr([ // this.$main
- '$mod.w = 0x1234;',
- '$mod.ss = -0x12;',
- '$mod.b = $mod.ss & 0xFF;',
- '$mod.b = ($mod.ss >> 8) & 0xFF;',
- '$mod.b = $mod.w & 0xFF;',
- '$mod.b = ($mod.w >> 8) & 0xFF;',
- '$mod.b2 = $mod.b & 0xF;',
- '$mod.b2 = ($mod.b >> 4) & 0xF;',
- '$mod.lw = 0x1234CDEF;',
- '$mod.w = $mod.lw & 0xFFFF;',
- '$mod.w = ($mod.lw >> 16) & 0xFFFF;',
- '$mod.ni = 0x123456789ABCD;',
- '$mod.lw = $mod.ni >>> 0;',
- '$mod.lw = Math.floor($mod.ni / 4294967296) >>> 0;',
- '']));
- end;
- procedure TTestModule.TestLoHiDelphiMode;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'const',
- ' LoByte1 = Lo(Word($1234));',
- ' HiByte1 = Hi(Word($1234));',
- ' LoByte2 = Lo(SmallInt($1234));',
- ' HiByte2 = Hi(SmallInt($1234));',
- ' LoByte3 = Lo($1234CDEF);',
- ' HiByte3 = Hi($1234CDEF);',
- ' LoByte4 = Lo(-$1234CDEF);',
- ' HiByte4 = Hi(-$1234CDEF);',
- 'var',
- ' b: Byte;',
- ' w: Word;',
- ' si: SmallInt;',
- ' lw: LongWord;',
- ' li: LongInt;',
- 'begin',
- ' w := $1234;',
- ' b := lo(w);',
- ' b := HI(w);',
- ' lw := $1234CDEF;',
- ' b := lo(lw);',
- ' b := hi(lw);',
- '']);
- ConvertProgram;
- CheckSource('TestLoHiDelphiMode',
- LinesToStr([ // statements
- 'this.LoByte1 = 0x1234 & 0xFF;',
- 'this.HiByte1 = (0x1234 >> 8) & 0xFF;',
- 'this.LoByte2 = 0x1234 & 0xFF;',
- 'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
- 'this.LoByte3 = 0x1234CDEF & 0xFF;',
- 'this.HiByte3 = (0x1234CDEF >> 8) & 0xFF;',
- 'this.LoByte4 = -0x1234CDEF & 0xFF;',
- 'this.HiByte4 = (-0x1234CDEF >> 8) & 0xFF;',
- 'this.b = 0;',
- 'this.w = 0;',
- 'this.si = 0;',
- 'this.lw = 0;',
- 'this.li = 0;'
- ]),
- LinesToStr([ // this.$main
- '$mod.w = 0x1234;',
- '$mod.b = $mod.w & 0xFF;',
- '$mod.b = ($mod.w >> 8) & 0xFF;',
- '$mod.lw = 0x1234CDEF;',
- '$mod.b = $mod.lw & 0xFF;',
- '$mod.b = ($mod.lw >> 8) & 0xFF;'
- ]));
- end;
- procedure TTestModule.TestAssignments;
- begin
- StartProgram(false);
- Parser.Options:=Parser.Options+[po_cassignments];
- Add('var');
- Add(' Bar:longint;');
- Add('begin');
- Add(' bar:=3;');
- Add(' bar+=4;');
- Add(' bar-=5;');
- Add(' bar*=6;');
- ConvertProgram;
- CheckSource('TestAssignments',
- LinesToStr([ // statements
- 'this.Bar = 0;'
- ]),
- LinesToStr([ // this.$main
- '$mod.Bar=3;',
- '$mod.Bar+=4;',
- '$mod.Bar-=5;',
- '$mod.Bar*=6;'
- ]));
- end;
- procedure TTestModule.TestArithmeticOperators1;
- begin
- StartProgram(false);
- Add('var');
- Add(' vA,vB,vC:longint;');
- Add('begin');
- Add(' va:=1;');
- Add(' vb:=va+va;');
- Add(' vb:=va div vb;');
- Add(' vb:=va mod vb;');
- Add(' vb:=va+va*vb+va div vb;');
- Add(' vc:=-va;');
- Add(' va:=va-vb;');
- Add(' vb:=va;');
- Add(' if va<vb then vc:=va else vc:=vb;');
- ConvertProgram;
- CheckSource('TestArithmeticOperators1',
- LinesToStr([ // statements
- 'this.vA = 0;',
- 'this.vB = 0;',
- 'this.vC = 0;'
- ]),
- LinesToStr([ // this.$main
- '$mod.vA = 1;',
- '$mod.vB = $mod.vA + $mod.vA;',
- '$mod.vB = rtl.trunc($mod.vA / $mod.vB);',
- '$mod.vB = $mod.vA % $mod.vB;',
- '$mod.vB = $mod.vA + ($mod.vA * $mod.vB) + rtl.trunc($mod.vA / $mod.vB);',
- '$mod.vC = -$mod.vA;',
- '$mod.vA = $mod.vA - $mod.vB;',
- '$mod.vB = $mod.vA;',
- 'if ($mod.vA < $mod.vB){ $mod.vC = $mod.vA } else $mod.vC = $mod.vB;'
- ]));
- end;
- procedure TTestModule.TestMultiAdd;
- begin
- StartProgram(false);
- Add([
- 'function TryEncodeDate(Year, Month, Day: Word): Boolean;',
- 'var Date: double;',
- 'begin',
- ' Result:=(Year>0) and (Year<10000) and',
- ' (Month >= 1) and (Month<=12) and',
- ' (Day>0) and (Day<=31);',
- ' Date := (146097*Year) SHR 2 + (1461*Year) SHR 2 + (153*LongWord(Month)+2) DIV 5 + LongWord(Day);',
- 'end;',
- 'var s: string;',
- 'begin',
- ' s:=''a''+''b''+''c''+''d'';']);
- ConvertProgram;
- CheckSource('TestMultiAdd',
- LinesToStr([ // statements
- 'this.TryEncodeDate = function (Year, Month, Day) {',
- ' var Result = false;',
- ' var date = 0.0;',
- ' Result = (Year > 0) && (Year < 10000) && (Month >= 1) && (Month <= 12) && (Day > 0) && (Day <= 31);',
- ' date = ((146097 * Year) >>> 2) + ((1461 * Year) >>> 2) + rtl.trunc(((153 * Month) + 2) / 5) + Day;',
- ' return Result;',
- '};',
- 'this.s = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.s = "a" + "b" + "c" + "d";',
- '']));
- end;
- procedure TTestModule.TestLogicalOperators;
- begin
- StartProgram(false);
- Add('var');
- Add(' vA,vB,vC:boolean;');
- Add('begin');
- Add(' va:=vb and vc;');
- Add(' va:=vb or vc;');
- Add(' va:=vb xor vc;');
- Add(' va:=true and vc;');
- Add(' va:=(vb and vc) or (va and vb);');
- Add(' va:=not vb;');
- ConvertProgram;
- CheckSource('TestLogicalOperators',
- LinesToStr([ // statements
- 'this.vA = false;',
- 'this.vB = false;',
- 'this.vC = false;'
- ]),
- LinesToStr([ // this.$main
- '$mod.vA = $mod.vB && $mod.vC;',
- '$mod.vA = $mod.vB || $mod.vC;',
- '$mod.vA = $mod.vB ^ $mod.vC;',
- '$mod.vA = true && $mod.vC;',
- '$mod.vA = ($mod.vB && $mod.vC) || ($mod.vA && $mod.vB);',
- '$mod.vA = !$mod.vB;'
- ]));
- end;
- procedure TTestModule.TestBitwiseOperators;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' vA,vB,vC:longint;',
- ' X,Y,Z: nativeint;',
- 'begin',
- ' va:=vb and vc;',
- ' va:=vb or vc;',
- ' va:=vb xor vc;',
- ' va:=vb shl vc;',
- ' va:=vb shr vc;',
- ' va:=3 and vc;',
- ' va:=(vb and vc) or (va and vb);',
- ' va:=not vb;',
- ' X:=Y and Z;',
- ' X:=Y and va;',
- ' X:=Y or Z;',
- ' X:=Y or va;',
- ' X:=Y xor Z;',
- ' X:=Y xor va;',
- '']);
- ConvertProgram;
- CheckSource('TestBitwiseOperators',
- LinesToStr([ // statements
- 'this.vA = 0;',
- 'this.vB = 0;',
- 'this.vC = 0;',
- 'this.X = 0;',
- 'this.Y = 0;',
- 'this.Z = 0;',
- '']),
- LinesToStr([ // this.$main
- '$mod.vA = $mod.vB & $mod.vC;',
- '$mod.vA = $mod.vB | $mod.vC;',
- '$mod.vA = $mod.vB ^ $mod.vC;',
- '$mod.vA = $mod.vB << $mod.vC;',
- '$mod.vA = $mod.vB >>> $mod.vC;',
- '$mod.vA = 3 & $mod.vC;',
- '$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
- '$mod.vA = ~$mod.vB;',
- '$mod.X = rtl.and($mod.Y, $mod.Z);',
- '$mod.X = $mod.Y & $mod.vA;',
- '$mod.X = rtl.or($mod.Y, $mod.Z);',
- '$mod.X = rtl.or($mod.Y, $mod.vA);',
- '$mod.X = rtl.xor($mod.Y, $mod.Z);',
- '$mod.X = rtl.xor($mod.Y, $mod.vA);',
- '']));
- end;
- procedure TTestModule.TestBitwiseOperatorsLongword;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' a,b,c:longword;',
- ' i: longint;',
- 'begin',
- ' a:=$12345678;',
- ' b:=$EDCBA987;',
- ' c:=not a;',
- ' c:=a and b;',
- ' c:=a and $ffff0000;',
- ' c:=a or b;',
- ' c:=a or $ff00ff00;',
- ' c:=a xor b;',
- ' c:=a xor $f0f0f0f0;',
- ' c:=a shl 1;',
- ' c:=a shl 16;',
- ' c:=a shl 24;',
- ' c:=a shl b;',
- ' c:=a shr 1;',
- ' c:=a shr 16;',
- ' c:=a shr 24;',
- ' c:=a shr b;',
- ' c:=(b and c) or (a and b);',
- ' c:=i and a;',
- ' c:=i or a;',
- ' c:=i xor a;',
- '']);
- ConvertProgram;
- CheckSource('TestBitwiseOperatorsLongword',
- LinesToStr([ // statements
- 'this.a = 0;',
- 'this.b = 0;',
- 'this.c = 0;',
- 'this.i = 0;',
- '']),
- LinesToStr([ // this.$main
- '$mod.a = 0x12345678;',
- '$mod.b = 0xEDCBA987;',
- '$mod.c = rtl.lw(~$mod.a);',
- '$mod.c = rtl.lw($mod.a & $mod.b);',
- '$mod.c = rtl.lw($mod.a & 0xffff0000);',
- '$mod.c = rtl.lw($mod.a | $mod.b);',
- '$mod.c = rtl.lw($mod.a | 0xff00ff00);',
- '$mod.c = rtl.lw($mod.a ^ $mod.b);',
- '$mod.c = rtl.lw($mod.a ^ 0xf0f0f0f0);',
- '$mod.c = rtl.lw($mod.a << 1);',
- '$mod.c = rtl.lw($mod.a << 16);',
- '$mod.c = rtl.lw($mod.a << 24);',
- '$mod.c = rtl.lw($mod.a << $mod.b);',
- '$mod.c = rtl.lw($mod.a >>> 1);',
- '$mod.c = rtl.lw($mod.a >>> 16);',
- '$mod.c = rtl.lw($mod.a >>> 24);',
- '$mod.c = rtl.lw($mod.a >>> $mod.b);',
- '$mod.c = rtl.lw(rtl.lw($mod.b & $mod.c) | rtl.lw($mod.a & $mod.b));',
- '$mod.c = $mod.i & $mod.a;',
- '$mod.c = $mod.i | $mod.a;',
- '$mod.c = $mod.i ^ $mod.a;',
- '']));
- end;
- procedure TTestModule.TestPrgProcVar;
- begin
- StartProgram(false);
- Add('procedure Proc1;');
- Add('type');
- Add(' t1=longint;');
- Add('var');
- Add(' vA:t1;');
- Add('begin');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestPrgProcVar',
- LinesToStr([ // statements
- 'this.Proc1 = function () {',
- ' var vA=0;',
- '};'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestUnitProcVar;
- begin
- StartUnit(false);
- Add('interface');
- Add('');
- Add('type tA=string; // unit scope');
- Add('procedure Proc1;');
- Add('');
- Add('implementation');
- Add('');
- Add('procedure Proc1;');
- Add('type tA=longint; // local proc scope');
- Add('var v1:tA; // using local tA');
- Add('begin');
- Add('end;');
- Add('var v2:tA; // using interface tA');
- ConvertUnit;
- CheckSource('TestUnitProcVar',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- 'this.Proc1 = function () {',
- ' var v1 = 0;',
- '};',
- '']),
- // this.$init
- '',
- // implementation
- LinesToStr([
- '$impl.v2 = "";',
- '']));
- end;
- procedure TTestModule.TestImplProc;
- begin
- StartUnit(false);
- Add('interface');
- Add('');
- Add('procedure Proc1;');
- Add('');
- Add('implementation');
- Add('');
- Add('procedure Proc1; begin end;');
- Add('procedure Proc2; begin end;');
- Add('initialization');
- Add(' Proc1;');
- Add(' Proc2;');
- ConvertUnit;
- CheckSource('TestImplProc',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- 'this.Proc1 = function () {',
- '};',
- '']),
- LinesToStr([ // this.$init
- '$mod.Proc1();',
- '$impl.Proc2();',
- '']),
- LinesToStr([ // implementation
- '$impl.Proc2 = function () {',
- '};',
- ''])
- );
- end;
- procedure TTestModule.TestFunctionResult;
- begin
- StartProgram(false);
- Add('function Func1: longint;');
- Add('begin');
- Add(' Result:=3;');
- Add(' Func1:=4;');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestFunctionResult',
- LinesToStr([ // statements
- 'this.Func1 = function () {',
- ' var Result = 0;',
- ' Result = 3;',
- ' Result = 4;',
- ' return Result;',
- '};'
- ]),
- '');
- end;
- procedure TTestModule.TestNestedProc;
- begin
- StartProgram(false);
- Add([
- 'var vInUnit: longint;',
- 'function DoIt(pA,pD: longint): longint;',
- 'var',
- ' vB: longint;',
- ' vC: longint;',
- ' function Nesty(pA: longint): longint; ',
- ' var vB: longint;',
- ' begin',
- ' Result:=pa+vb+vc+pd+vInUnit;',
- ' nesty:=3;',
- ' doit:=4;',
- ' exit;',
- ' end;',
- 'begin',
- ' Result:=pa+vb+vc;',
- ' doit:=6;',
- ' exit;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestNestedProc',
- LinesToStr([ // statements
- 'this.vInUnit = 0;',
- 'this.DoIt = function (pA, pD) {',
- ' var Result = 0;',
- ' var vB = 0;',
- ' var vC = 0;',
- ' function Nesty(pA) {',
- ' var Result$1 = 0;',
- ' var vB = 0;',
- ' Result$1 = pA + vB + vC + pD + $mod.vInUnit;',
- ' Result$1 = 3;',
- ' Result = 4;',
- ' return Result$1;',
- ' return Result$1;',
- ' };',
- ' Result = pA + vB + vC;',
- ' Result = 6;',
- ' return Result;',
- ' return Result;',
- '};'
- ]),
- '');
- end;
- procedure TTestModule.TestNestedProc_ResultString;
- begin
- StartProgram(false);
- Add([
- 'function DoIt: string;',
- ' function Nesty: string; ',
- ' begin',
- ' nesty:=#65#66;',
- ' nesty[1]:=#67;',
- ' doit:=#68;',
- ' doit[2]:=#69;',
- ' end;',
- 'begin',
- ' doit:=#70;',
- ' doit[3]:=#71;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestNestedProc_ResultString',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' var Result = "";',
- ' function Nesty() {',
- ' var Result$1 = "";',
- ' Result$1 = "AB";',
- ' Result$1 = rtl.setCharAt(Result$1, 0, "C");',
- ' Result = "D";',
- ' Result = rtl.setCharAt(Result, 1, "E");',
- ' return Result$1;',
- ' };',
- ' Result = "F";',
- ' Result = rtl.setCharAt(Result, 2, "G");',
- ' return Result;',
- '};'
- ]),
- '');
- end;
- procedure TTestModule.TestForwardProc;
- begin
- StartProgram(false);
- Add('procedure FuncA(Bar: longint); forward;');
- Add('procedure FuncB(Bar: longint);');
- Add('begin');
- Add(' funca(bar);');
- Add('end;');
- Add('procedure funca(bar: longint);');
- Add('begin');
- Add(' if bar=3 then ;');
- Add('end;');
- Add('begin');
- Add(' funca(4);');
- Add(' funcb(5);');
- ConvertProgram;
- CheckSource('TestForwardProc',
- LinesToStr([ // statements'
- 'this.FuncB = function (Bar) {',
- ' $mod.FuncA(Bar);',
- '};',
- 'this.FuncA = function (Bar) {',
- ' if (Bar === 3);',
- '};'
- ]),
- LinesToStr([
- '$mod.FuncA(4);',
- '$mod.FuncB(5);'
- ])
- );
- end;
- procedure TTestModule.TestNestedForwardProc;
- begin
- StartProgram(false);
- Add('procedure FuncA;');
- Add(' procedure FuncB(i: longint); forward;');
- Add(' procedure FuncC(i: longint);');
- Add(' begin');
- Add(' funcb(i);');
- Add(' end;');
- Add(' procedure FuncB(i: longint);');
- Add(' begin');
- Add(' if i=3 then ;');
- Add(' end;');
- Add('begin');
- Add(' funcc(4)');
- Add('end;');
- Add('begin');
- Add(' funca;');
- ConvertProgram;
- CheckSource('TestNestedForwardProc',
- LinesToStr([ // statements'
- 'this.FuncA = function () {',
- ' function FuncC(i) {',
- ' FuncB(i);',
- ' };',
- ' function FuncB(i) {',
- ' if (i === 3);',
- ' };',
- ' FuncC(4);',
- '};'
- ]),
- LinesToStr([
- '$mod.FuncA();'
- ])
- );
- end;
- procedure TTestModule.TestAssignFunctionResult;
- begin
- StartProgram(false);
- Add('function Func1: longint;');
- Add('begin');
- Add('end;');
- Add('var i: longint;');
- Add('begin');
- Add(' i:=func1();');
- Add(' i:=func1()+func1();');
- ConvertProgram;
- CheckSource('TestAssignFunctionResult',
- LinesToStr([ // statements
- 'this.Func1 = function () {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.i = 0;'
- ]),
- LinesToStr([
- '$mod.i = $mod.Func1();',
- '$mod.i = $mod.Func1() + $mod.Func1();'
- ]));
- end;
- procedure TTestModule.TestFunctionResultInCondition;
- begin
- StartProgram(false);
- Add('function Func1: longint;');
- Add('begin');
- Add('end;');
- Add('function Func2: boolean;');
- Add('begin');
- Add('end;');
- Add('var i: longint;');
- Add('begin');
- Add(' if func2 then ;');
- Add(' if i=func1() then ;');
- Add(' if i=func1 then ;');
- ConvertProgram;
- CheckSource('TestFunctionResultInCondition',
- LinesToStr([ // statements
- 'this.Func1 = function () {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.Func2 = function () {',
- ' var Result = false;',
- ' return Result;',
- '};',
- 'this.i = 0;'
- ]),
- LinesToStr([
- 'if ($mod.Func2());',
- 'if ($mod.i === $mod.Func1());',
- 'if ($mod.i === $mod.Func1());'
- ]));
- end;
- procedure TTestModule.TestFunctionResultInForLoop;
- begin
- StartProgram(false);
- Add([
- 'function Func1(a: array of longint): longint;',
- 'begin',
- ' for Result:=High(a) downto Low(a) do if a[Result]=0 then exit;',
- ' for Result in a do if a[Result]=0 then exit;',
- 'end;',
- 'begin',
- ' Func1([1,2,3])']);
- ConvertProgram;
- CheckSource('TestFunctionResultInForLoop',
- LinesToStr([ // statements
- 'this.Func1 = function (a) {',
- ' var Result = 0;',
- ' for (var $l = rtl.length(a) - 1; $l >= 0; $l--) {',
- ' Result = $l;',
- ' if (a[Result] === 0) return Result;',
- ' };',
- ' for (var $in = a, $l1 = 0, $end = rtl.length($in) - 1; $l1 <= $end; $l1++) {',
- ' Result = $in[$l1];',
- ' if (a[Result] === 0) return Result;',
- ' };',
- ' return Result;',
- '};',
- '']),
- LinesToStr([
- '$mod.Func1([1, 2, 3]);'
- ]));
- end;
- procedure TTestModule.TestFunctionResultInTypeCast;
- begin
- StartProgram(false);
- Add([
- 'function GetInt: longint;',
- 'begin',
- 'end;',
- 'begin',
- ' if Byte(GetInt)=0 then ;',
- '']);
- ConvertProgram;
- CheckSource('TestFunctionResultInTypeCast',
- LinesToStr([ // statements
- 'this.GetInt = function () {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- '']),
- LinesToStr([
- 'if (($mod.GetInt() & 255) === 0) ;'
- ]));
- end;
- procedure TTestModule.TestExit;
- begin
- StartProgram(false);
- Add('procedure ProcA;');
- Add('begin');
- Add(' exit;');
- Add('end;');
- Add('function FuncB: longint;');
- Add('begin');
- Add(' exit;');
- Add(' exit(3);');
- Add('end;');
- Add('function FuncC: string;');
- Add('begin');
- Add(' exit;');
- Add(' exit(''a'');');
- Add(' exit(''abc'');');
- Add('end;');
- Add('begin');
- Add(' exit;');
- Add(' exit(1);');
- ConvertProgram;
- CheckSource('TestExit',
- LinesToStr([ // statements
- 'this.ProcA = function () {',
- ' return;',
- '};',
- 'this.FuncB = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' return 3;',
- ' return Result;',
- '};',
- 'this.FuncC = function () {',
- ' var Result = "";',
- ' return Result;',
- ' return "a";',
- ' return "abc";',
- ' return Result;',
- '};'
- ]),
- LinesToStr([
- 'return;',
- 'return 1;',
- '']));
- end;
- procedure TTestModule.TestExit_ResultInFinally;
- begin
- StartProgram(false);
- Add([
- 'function Run: word;',
- 'begin',
- ' try',
- ' exit(3);', // no Result in finally -> use return 3
- ' finally',
- ' end;',
- 'end;',
- 'function Fly: word;',
- 'begin',
- ' try',
- ' exit(3);',
- ' finally',
- ' if Result>0 then ;',
- ' end;',
- 'end;',
- 'function Jump: word;',
- 'begin',
- ' try',
- ' try',
- ' exit(4);',
- ' finally',
- ' end;',
- ' finally',
- ' if Result>0 then ;',
- ' end;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestExit_ResultInFinally',
- LinesToStr([ // statements
- 'this.Run = function () {',
- ' var Result = 0;',
- ' try {',
- ' return 3;',
- ' } finally {',
- ' };',
- ' return Result;',
- '};',
- 'this.Fly = function () {',
- ' var Result = 0;',
- ' try {',
- ' Result = 3;',
- ' return Result;',
- ' } finally {',
- ' if (Result > 0) ;',
- ' };',
- ' return Result;',
- '};',
- 'this.Jump = function () {',
- ' var Result = 0;',
- ' try {',
- ' try {',
- ' Result = 4;',
- ' return Result;',
- ' } finally {',
- ' };',
- ' } finally {',
- ' if (Result > 0) ;',
- ' };',
- ' return Result;',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestBreak;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' i: longint;',
- 'begin',
- ' repeat',
- ' break;',
- ' until true;',
- ' while true do',
- ' break;',
- ' for i:=1 to 2 do',
- ' break;']);
- ConvertProgram;
- CheckSource('TestBreak',
- LinesToStr([ // statements
- 'this.i = 0;'
- ]),
- LinesToStr([
- 'do {',
- ' break;',
- '} while (!true);',
- 'while (true) break;',
- 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) break;',
- '']));
- end;
- procedure TTestModule.TestBreakAsVar;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt(break: boolean);',
- 'begin',
- ' if break then ;',
- 'end;',
- 'var',
- ' break: boolean;',
- 'begin',
- ' if break then ;']);
- ConvertProgram;
- CheckSource('TestBreakAsVar',
- LinesToStr([ // statements
- 'this.DoIt = function (Break) {',
- ' if (Break) ;',
- '};',
- 'this.Break = false;',
- '']),
- LinesToStr([
- 'if($mod.Break) ;',
- '']));
- end;
- procedure TTestModule.TestContinue;
- begin
- StartProgram(false);
- Add('var i: longint;');
- Add('begin');
- Add(' repeat');
- Add(' continue;');
- Add(' until true;');
- Add(' while true do');
- Add(' continue;');
- Add(' for i:=1 to 2 do');
- Add(' continue;');
- ConvertProgram;
- CheckSource('TestContinue',
- LinesToStr([ // statements
- 'this.i = 0;'
- ]),
- LinesToStr([
- 'do {',
- ' continue;',
- '} while (!true);',
- 'while (true) continue;',
- 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) continue;',
- '']));
- end;
- procedure TTestModule.TestProc_External;
- begin
- StartProgram(false);
- Add('procedure Foo; external name ''console.log'';');
- Add('function Bar: longint; external name ''get.item'';');
- Add('function Bla(s: string): longint; external name ''apply.something'';');
- Add('var');
- Add(' i: longint;');
- Add('begin');
- Add(' Foo;');
- Add(' i:=Bar;');
- Add(' i:=Bla(''abc'');');
- ConvertProgram;
- CheckSource('TestProc_External',
- LinesToStr([ // statements
- 'this.i = 0;'
- ]),
- LinesToStr([
- 'console.log();',
- '$mod.i = get.item();',
- '$mod.i = apply.something("abc");'
- ]));
- end;
- procedure TTestModule.TestProc_ExternalOtherUnit;
- begin
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- 'procedure Now; external name ''Date.now'';',
- 'procedure DoIt;'
- ]),
- 'procedure doit; begin end;');
- StartUnit(true);
- Add('interface');
- Add('uses unit2;');
- Add('implementation');
- Add('begin');
- Add(' now;');
- Add(' now();');
- Add(' uNit2.now;');
- Add(' uNit2.now();');
- Add(' doit;');
- Add(' uNit2.doit;');
- ConvertUnit;
- CheckSource('TestProc_ExternalOtherUnit',
- LinesToStr([
- '']),
- LinesToStr([
- 'Date.now();',
- 'Date.now();',
- 'Date.now();',
- 'Date.now();',
- 'pas.unit2.DoIt();',
- 'pas.unit2.DoIt();',
- '']));
- end;
- procedure TTestModule.TestProc_Asm;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'function DoIt: longint;',
- 'begin;',
- ' asm',
- ' { a:{ b:{}, c:[]}, d:''1'' };',
- ' end;',
- ' asm console.log(); end;',
- ' asm',
- ' s = "'' ";',
- ' s = ''" '';',
- ' s = s + "world" + "''";',
- ' // end',
- ' s = ''end'';',
- ' s = "end";',
- ' s = "foo\"bar";',
- ' s = ''a\''b'';',
- ' s = `${expr}\`-"-''-`;',
- ' s = `multi',
- 'line`;',
- ' end;',
- 'end;',
- 'procedure Fly;',
- 'asm',
- ' return;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestProc_Asm',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' var Result = 0;',
- ' { a:{ b:{}, c:[]}, d:''1'' };',
- ' console.log();',
- ' s = "'' ";',
- ' s = ''" '';',
- ' s = s + "world" + "''";',
- ' // end',
- ' s = ''end'';',
- ' s = "end";',
- ' s = "foo\"bar";',
- ' s = ''a\''b'';',
- ' s = `${expr}\`-"-''-`;',
- ' s = `multi',
- 'line`;',
- ' return Result;',
- '};',
- 'this.Fly = function () {',
- ' return;',
- '};',
- '']),
- LinesToStr([
- ''
- ]));
- end;
- procedure TTestModule.TestProc_AsmSubBlock;
- begin
- StartProgram(true,[supTObject]);
- Add([
- '{$mode delphi}',
- 'type',
- ' TBird = class end;',
- 'procedure Run(w: word);',
- 'begin;',
- ' if true then asm console.log(); end;',
- ' if w>3 then asm',
- ' var a = w+1;',
- ' w = a+3;',
- ' end;',
- ' while (w>7) do asm',
- ' w+=3; w*=2;',
- ' end;',
- ' try',
- ' except',
- ' on E: TBird do',
- ' asm console.log(E); end;',
- ' on E: TObject do',
- ' asm var i=3; i--; end;',
- ' else asm Fly; High; end;',
- ' end;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestProc_AsmSubBlock',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TBird", pas.system.TObject, function () {',
- '});',
- 'this.Run = function (w) {',
- ' if (true) console.log();',
- ' if (w > 3) {',
- ' var a = w+1;',
- ' w = a+3;',
- ' };',
- ' while (w > 7) {',
- ' w+=3; w*=2;',
- ' };',
- ' try {} catch ($e) {',
- ' if ($mod.TBird.isPrototypeOf($e)) {',
- ' var E = $e;',
- ' console.log(E);',
- ' } else if (pas.system.TObject.isPrototypeOf($e)) {',
- ' var E = $e;',
- ' var i=3; i--;',
- ' } else {',
- ' Fly; High;',
- ' }',
- ' };',
- '};',
- '']),
- LinesToStr([
- ''
- ]));
- end;
- procedure TTestModule.TestProc_Assembler;
- begin
- StartProgram(false);
- Add('function DoIt: longint; assembler;');
- Add('asm');
- Add('{ a:{ b:{}, c:[]}, d:''1'' };');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestProc_Assembler',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' { a:{ b:{}, c:[]}, d:''1'' };',
- '};'
- ]),
- LinesToStr([
- ''
- ]));
- end;
- procedure TTestModule.TestProc_VarParam;
- begin
- StartProgram(false);
- Add('type integer = longint;');
- Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
- Add('var vJ: integer;');
- Add('begin');
- Add(' vg:=vg+1;');
- Add(' vj:=vh+2;');
- Add(' vi:=vi+3;');
- Add(' doit(vg,vg,vg);');
- Add(' doit(vh,vh,vj);');
- Add(' doit(vi,vi,vi);');
- Add(' doit(vj,vj,vj);');
- Add('end;');
- Add('var i: integer;');
- Add('begin');
- Add(' doit(i,i,i);');
- ConvertProgram;
- CheckSource('TestProc_VarParam',
- LinesToStr([ // statements
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = 0;',
- ' vG = vG + 1;',
- ' vJ = vH + 2;',
- ' vI.set(vI.get()+3);',
- ' $mod.DoIt(vG, vG, {',
- ' get: function () {',
- ' return vG;',
- ' },',
- ' set: function (v) {',
- ' vG = v;',
- ' }',
- ' });',
- ' $mod.DoIt(vH, vH, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- ' $mod.DoIt(vI.get(), vI.get(), vI);',
- ' $mod.DoIt(vJ, vJ, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- '};',
- 'this.i = 0;'
- ]),
- LinesToStr([
- '$mod.DoIt($mod.i,$mod.i,{',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});'
- ]));
- end;
- procedure TTestModule.TestProc_VarParamString;
- begin
- StartProgram(false);
- Add(['type TCaption = string;',
- 'procedure DoIt(vA: TCaption; var vB: TCaption; out vC: TCaption);',
- 'var c: char;',
- 'begin',
- ' va[1]:=c;',
- ' vb[2]:=c;',
- ' vc[3]:=c;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestProc_VarParamString',
- LinesToStr([ // statements
- 'this.DoIt = function (vA,vB,vC) {',
- ' var c = "";',
- ' vA = rtl.setCharAt(vA, 0, c);',
- ' vB.set(rtl.setCharAt(vB.get(), 1, c));',
- ' vC.set(rtl.setCharAt(vC.get(), 2, c));',
- '};',
- '']),
- LinesToStr([
- ]));
- end;
- procedure TTestModule.TestProc_VarParamV;
- begin
- StartProgram(false);
- Add([
- 'procedure Inc2(var i: longint);',
- 'begin',
- ' i:=i+2;',
- 'end;',
- 'procedure DoIt(v: longint);',
- 'var p: array of longint;',
- 'begin',
- ' Inc2(v);',
- ' Inc2(p[v]);',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestProc_VarParamV',
- LinesToStr([ // statements
- 'this.Inc2 = function (i) {',
- ' i.set(i.get()+2);',
- '};',
- 'this.DoIt = function (v) {',
- ' var p = [];',
- ' $mod.Inc2({get: function () {',
- ' return v;',
- ' }, set: function (w) {',
- ' v = w;',
- ' }});',
- ' $mod.Inc2({',
- ' a: v,',
- ' p: p,',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- ' });',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestProc_Overload;
- begin
- StartProgram(false);
- Add('procedure DoIt(vI: longint); begin end;');
- Add('procedure DoIt(vI, vJ: longint); begin end;');
- Add('procedure DoIt(vD: double); begin end;');
- Add('begin');
- Add(' DoIt(1);');
- Add(' DoIt(2,3);');
- Add(' DoIt(4.5);');
- ConvertProgram;
- CheckSource('TestProcedureOverload',
- LinesToStr([ // statements
- 'this.DoIt = function (vI) {',
- '};',
- 'this.DoIt$1 = function (vI, vJ) {',
- '};',
- 'this.DoIt$2 = function (vD) {',
- '};',
- '']),
- LinesToStr([
- '$mod.DoIt(1);',
- '$mod.DoIt$1(2, 3);',
- '$mod.DoIt$2(4.5);',
- '']));
- end;
- procedure TTestModule.TestProc_OverloadForward;
- begin
- StartProgram(false);
- Add('procedure DoIt(vI: longint); forward;');
- Add('procedure DoIt(vI, vJ: longint); begin end;');
- Add('procedure doit(vi: longint); begin end;');
- Add('begin');
- Add(' doit(1);');
- Add(' doit(2,3);');
- ConvertProgram;
- CheckSource('TestProcedureOverloadForward',
- LinesToStr([ // statements
- 'this.DoIt$1 = function (vI, vJ) {',
- '};',
- 'this.DoIt = function (vI) {',
- '};',
- '']),
- LinesToStr([
- '$mod.DoIt(1);',
- '$mod.DoIt$1(2, 3);',
- '']));
- end;
- procedure TTestModule.TestProc_OverloadIntfImpl;
- begin
- StartUnit(false);
- Add('interface');
- Add('procedure DoIt(vI: longint);');
- Add('procedure DoIt(vI, vJ: longint);');
- Add('implementation');
- Add('procedure DoIt(vI, vJ, vK, vL, vM: longint); forward;');
- Add('procedure DoIt(vI, vJ, vK: longint); begin end;');
- Add('procedure DoIt(vi: longint); begin end;');
- Add('procedure DoIt(vI, vJ, vK, vL: longint); begin end;');
- Add('procedure DoIt(vi, vj: longint); begin end;');
- Add('procedure DoIt(vi, vj, vk, vl, vm: longint); begin end;');
- Add('begin');
- Add(' doit(1);');
- Add(' doit(2,3);');
- Add(' doit(4,5,6);');
- Add(' doit(7,8,9,10);');
- Add(' doit(11,12,13,14,15);');
- ConvertUnit;
- CheckSource('TestProcedureOverloadUnit',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- 'this.DoIt = function (vI) {',
- '};',
- 'this.DoIt$1 = function (vI, vJ) {',
- '};',
- '']),
- LinesToStr([ // this.$init
- '$mod.DoIt(1);',
- '$mod.DoIt$1(2, 3);',
- '$impl.DoIt$3(4,5,6);',
- '$impl.DoIt$4(7,8,9,10);',
- '$impl.DoIt$2(11,12,13,14,15);',
- '']),
- LinesToStr([ // implementation
- '$impl.DoIt$3 = function (vI, vJ, vK) {',
- '};',
- '$impl.DoIt$4 = function (vI, vJ, vK, vL) {',
- '};',
- '$impl.DoIt$2 = function (vI, vJ, vK, vL, vM) {',
- '};',
- '']));
- end;
- procedure TTestModule.TestProc_OverloadNested;
- begin
- StartProgram(false);
- Add([
- 'procedure doit(vA: longint);',
- ' procedure DoIt(vA, vB: longint); overload;',
- ' begin',
- ' doit(1);',
- ' doit(1,2);',
- ' end;',
- ' procedure doit(vA, vB, vC: longint);',
- ' begin',
- ' doit(1);',
- ' doit(1,2);',
- ' doit(1,2,3);',
- ' end;',
- 'begin',
- ' doit(1);',
- ' doit(1,2);',
- ' doit(1,2,3);',
- 'end;',
- 'begin // main',
- ' doit(1);']);
- ConvertProgram;
- CheckSource('TestProcedureOverloadNested',
- LinesToStr([ // statements
- 'this.doit = function (vA) {',
- ' function DoIt$1(vA, vB) {',
- ' $mod.doit(1);',
- ' DoIt$1(1, 2);',
- ' };',
- ' function doit$2(vA, vB, vC) {',
- ' $mod.doit(1);',
- ' DoIt$1(1, 2);',
- ' doit$2(1, 2, 3);',
- ' };',
- ' $mod.doit(1);',
- ' DoIt$1(1, 2);',
- ' doit$2(1, 2, 3);',
- '};',
- '']),
- LinesToStr([
- '$mod.doit(1);',
- '']));
- end;
- procedure TTestModule.TestProc_OverloadNestedForward;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt(vA: longint); overload; forward;',
- 'procedure DoIt(vB, vC: longint); overload;',
- 'begin // 2 param overload',
- ' doit(1);',
- ' doit(1,2);',
- 'end;',
- 'procedure doit(vA: longint);',
- ' procedure DoIt(vA, vB, vC: longint); overload; forward;',
- ' procedure DoIt(vA, vB, vC, vD: longint); overload;',
- ' begin // 4 param overload',
- ' doit(1);',
- ' doit(1,2);',
- ' doit(1,2,3);',
- ' doit(1,2,3,4);',
- ' end;',
- ' procedure doit(vA, vB, vC: longint);',
- ' procedure DoIt(vA, vB, vC, vD, vE: longint); overload; forward;',
- ' procedure DoIt(vA, vB, vC, vD, vE, vF: longint); overload;',
- ' begin // 6 param overload',
- ' doit(1);',
- ' doit(1,2);',
- ' doit(1,2,3);',
- ' doit(1,2,3,4);',
- ' doit(1,2,3,4,5);',
- ' doit(1,2,3,4,5,6);',
- ' end;',
- ' procedure doit(vA, vB, vC, vD, vE: longint);',
- ' begin // 5 param overload',
- ' doit(1);',
- ' doit(1,2);',
- ' doit(1,2,3);',
- ' doit(1,2,3,4);',
- ' doit(1,2,3,4,5);',
- ' doit(1,2,3,4,5,6);',
- ' end;',
- ' begin // 3 param overload',
- ' doit(1);',
- ' doit(1,2);',
- ' doit(1,2,3);',
- ' doit(1,2,3,4);',
- ' doit(1,2,3,4,5);',
- ' doit(1,2,3,4,5,6);',
- ' end;',
- 'begin // 1 param overload',
- ' doit(1);',
- ' doit(1,2);',
- ' doit(1,2,3);',
- ' doit(1,2,3,4);',
- 'end;',
- 'begin // main',
- ' doit(1);',
- ' doit(1,2);']);
- ConvertProgram;
- CheckSource('TestProc_OverloadNestedForward',
- LinesToStr([ // statements
- 'this.DoIt$1 = function (vB, vC) {',
- ' $mod.DoIt(1);',
- ' $mod.DoIt$1(1, 2);',
- '};',
- 'this.DoIt = function (vA) {',
- ' function DoIt$3(vA, vB, vC, vD) {',
- ' $mod.DoIt(1);',
- ' $mod.DoIt$1(1, 2);',
- ' DoIt$2(1, 2, 3);',
- ' DoIt$3(1, 2, 3, 4);',
- ' };',
- ' function DoIt$2(vA, vB, vC) {',
- ' function DoIt$5(vA, vB, vC, vD, vE, vF) {',
- ' $mod.DoIt(1);',
- ' $mod.DoIt$1(1, 2);',
- ' DoIt$2(1, 2, 3);',
- ' DoIt$3(1, 2, 3, 4);',
- ' DoIt$4(1, 2, 3, 4, 5);',
- ' DoIt$5(1, 2, 3, 4, 5, 6);',
- ' };',
- ' function DoIt$4(vA, vB, vC, vD, vE) {',
- ' $mod.DoIt(1);',
- ' $mod.DoIt$1(1, 2);',
- ' DoIt$2(1, 2, 3);',
- ' DoIt$3(1, 2, 3, 4);',
- ' DoIt$4(1, 2, 3, 4, 5);',
- ' DoIt$5(1, 2, 3, 4, 5, 6);',
- ' };',
- ' $mod.DoIt(1);',
- ' $mod.DoIt$1(1, 2);',
- ' DoIt$2(1, 2, 3);',
- ' DoIt$3(1, 2, 3, 4);',
- ' DoIt$4(1, 2, 3, 4, 5);',
- ' DoIt$5(1, 2, 3, 4, 5, 6);',
- ' };',
- ' $mod.DoIt(1);',
- ' $mod.DoIt$1(1, 2);',
- ' DoIt$2(1, 2, 3);',
- ' DoIt$3(1, 2, 3, 4);',
- '};',
- '']),
- LinesToStr([
- '$mod.DoIt(1);',
- '$mod.DoIt$1(1, 2);',
- '']));
- end;
- procedure TTestModule.TestProc_OverloadUnitCycle;
- begin
- AddModuleWithIntfImplSrc('Unit2.pas',
- LinesToStr([
- 'type',
- ' TObject = class',
- ' procedure DoIt(b: boolean); virtual; abstract;',
- ' procedure DoIt(i: longint); virtual; abstract;',
- ' end;',
- '']),
- 'uses test1;');
- StartUnit(true);
- Add([
- 'interface',
- 'uses unit2;',
- 'type',
- ' TEagle = class(TObject)',
- ' procedure DoIt(b: boolean); override;',
- ' procedure DoIt(i: longint); override;',
- ' end;',
- 'implementation',
- 'procedure TEagle.DoIt(b: boolean); begin end;',
- 'procedure TEagle.DoIt(i: longint); begin end;',
- '']);
- ConvertUnit;
- CheckSource('TestProc_OverloadUnitCycle',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TEagle", pas.Unit2.TObject, function () {',
- ' this.DoIt = function (b) {',
- ' };',
- ' this.DoIt$1 = function (i) {',
- ' };',
- '});',
- '']),
- '',
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestProc_Varargs;
- begin
- StartProgram(false);
- Add([
- 'procedure ProcA(i:longint); varargs; external name ''ProcA'';',
- 'procedure ProcB; varargs; external name ''ProcB'';',
- 'procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';',
- 'function GetIt: longint; begin end;',
- 'begin',
- ' ProcA(1);',
- ' ProcA(1,2);',
- ' ProcA(1,2.0);',
- ' ProcA(1,2,3);',
- ' ProcA(1,''2'');',
- ' ProcA(2,'''');',
- ' ProcA(3,false);',
- ' ProcB;',
- ' ProcB();',
- ' ProcB(4);',
- ' ProcB(''foo'');',
- ' ProcC;',
- ' ProcC();',
- ' ProcC(4);',
- ' ProcC(5,''foo'');',
- ' ProcB(GetIt);',
- ' ProcB(GetIt());',
- ' ProcB(GetIt,GetIt());']);
- ConvertProgram;
- CheckSource('TestProc_Varargs',
- LinesToStr([ // statements
- 'this.GetIt = function () {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- '']),
- LinesToStr([
- 'ProcA(1);',
- 'ProcA(1, 2);',
- 'ProcA(1, 2.0);',
- 'ProcA(1, 2, 3);',
- 'ProcA(1, "2");',
- 'ProcA(2, "");',
- 'ProcA(3, false);',
- 'ProcB();',
- 'ProcB();',
- 'ProcB(4);',
- 'ProcB("foo");',
- 'ProcC(17);',
- 'ProcC(17);',
- 'ProcC(4);',
- 'ProcC(5, "foo");',
- 'ProcB($mod.GetIt());',
- 'ProcB($mod.GetIt());',
- 'ProcB($mod.GetIt(), $mod.GetIt());',
- '']));
- end;
- procedure TTestModule.TestProc_ConstOrder;
- begin
- StartProgram(false);
- Add([
- 'const A = 3;',
- 'const B = A+1;',
- 'procedure DoIt;',
- 'const C = A+1;',
- 'const D = B+1;',
- 'const E = D+C+B+A;',
- 'begin',
- 'end;',
- 'begin'
- ]);
- ConvertProgram;
- CheckSource('TestProc_ConstOrder',
- LinesToStr([ // statements
- 'this.A = 3;',
- 'this.B = 3 + 1;',
- 'var C = 3 + 1;',
- 'var D = 4 + 1;',
- 'var E = 5 + 4 + 4 + 3;',
- 'this.DoIt = function () {',
- '};',
- '']),
- LinesToStr([
- ''
- ]));
- end;
- procedure TTestModule.TestProc_DuplicateConst;
- begin
- StartProgram(false);
- Add([
- 'const A = 1;',
- 'procedure DoIt;',
- 'const A = 2;',
- ' procedure SubIt;',
- ' const A = 21;',
- ' begin',
- ' end;',
- 'begin',
- 'end;',
- 'procedure DoSome;',
- 'const A = 3;',
- 'begin',
- 'end;',
- 'begin'
- ]);
- ConvertProgram;
- CheckSource('TestProc_DuplicateConst',
- LinesToStr([ // statements
- 'this.A = 1;',
- 'var A$1 = 2;',
- 'var A$2 = 21;',
- 'this.DoIt = function () {',
- ' function SubIt() {',
- ' };',
- '};',
- 'var A$3 = 3;',
- 'this.DoSome = function () {',
- '};',
- '']),
- LinesToStr([
- ''
- ]));
- end;
- procedure TTestModule.TestProc_LocalVarAbsolute;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' Index: longint;',
- ' procedure DoAbs(Item: pointer);',
- ' end;',
- 'procedure TObject.DoAbs(Item: pointer);',
- 'var',
- ' o: TObject absolute Item;',
- 'begin',
- ' if o.Index<o.Index then o.Index:=o.Index;',
- 'end;',
- 'procedure DoIt(i: longint; p: pointer);',
- 'var',
- ' d: double absolute i;',
- ' s: string absolute d;',
- ' oi: TObject absolute i;',
- ' op: TObject absolute p;',
- 'begin',
- ' if d=d then d:=d;',
- ' if s=s then s:=s;',
- ' if oi.Index<oi.Index then oi.Index:=oi.Index;',
- ' if op.Index=op.Index then op.Index:=op.Index;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestProc_LocalVarAbsolute',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Index = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoAbs = function (Item) {',
- ' if (Item.Index < Item.Index) Item.Index = Item.Index;',
- ' };',
- '});',
- 'this.DoIt = function (i, p) {',
- ' if (i === i) i = i;',
- ' if (i === i) i = i;',
- ' if (i.Index < i.Index) i.Index = i.Index;',
- ' if (p.Index === p.Index) p.Index = p.Index;',
- '};'
- ]),
- LinesToStr([
- ]));
- end;
- procedure TTestModule.TestProc_LocalVarInit;
- begin
- StartProgram(false);
- Add([
- 'type TBytes = array of byte;',
- 'procedure DoIt;',
- 'const c = 4;',
- 'var',
- ' b: byte = 1;',
- ' w: word = 2+c;',
- ' p: pointer = nil;',
- ' Buffer: TBytes = nil;',
- 'begin',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestProc_LocalVarInit',
- LinesToStr([ // statements
- 'var c = 4;',
- 'this.DoIt = function () {',
- ' var b = 1;',
- ' var w = 2 + 4;',
- ' var p = null;',
- ' var Buffer = [];',
- '};',
- '']),
- LinesToStr([
- ]));
- end;
- procedure TTestModule.TestProc_ReservedWords;
- begin
- StartProgram(false);
- Add([
- 'procedure Date(ArrayBuffer: longint);',
- 'const',
- ' NaN: longint = 3;',
- 'var',
- ' &Boolean: longint;',
- ' procedure Error(ArrayBuffer: longint);',
- ' begin',
- ' end;',
- 'begin',
- ' Nan:=&bOolean;',
- 'end;',
- 'begin',
- ' Date(1);']);
- ConvertProgram;
- CheckSource('TestProc_ReservedWords',
- LinesToStr([ // statements
- 'var naN = 3;',
- 'this.Date = function (arrayBuffer) {',
- ' var boolean = 0;',
- ' function error(arrayBuffer) {',
- ' };',
- ' naN = boolean;',
- '};',
- '']),
- LinesToStr([
- ' $mod.Date(1);'
- ]));
- end;
- procedure TTestModule.TestProc_ConstRefWord;
- begin
- StartProgram(false);
- Add([
- 'procedure Run(constref w: word);',
- 'var l: word;',
- 'begin',
- ' l:=w;',
- ' Run(w);',
- ' Run(l);',
- 'end;',
- 'procedure Fly(a: word; var b: word; out c: word; const d: word; constref e: word);',
- 'begin',
- ' Run(a);',
- ' Run(b);',
- ' Run(c);',
- ' Run(d);',
- ' Run(e);',
- 'end;',
- 'begin',
- ' Run(1);']);
- ConvertProgram;
- CheckHint(mtWarning,nConstRefNotForXAsConst,'ConstRef not yet implemented for Word. Treating as Const');
- CheckSource('TestProc_ConstRefWord',
- LinesToStr([ // statements
- 'this.Run = function (w) {',
- ' var l = 0;',
- ' l = w;',
- ' $mod.Run(w);',
- ' $mod.Run(l);',
- '};',
- 'this.Fly = function (a, b, c, d, e) {',
- ' $mod.Run(a);',
- ' $mod.Run(b.get());',
- ' $mod.Run(c.get());',
- ' $mod.Run(d);',
- ' $mod.Run(e);',
- '};',
- '']),
- LinesToStr([
- '$mod.Run(1);'
- ]));
- end;
- procedure TTestModule.TestAnonymousProc_Assign_ObjFPC;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- 'type',
- ' TFunc = reference to function(x: word): word;',
- 'var Func: TFunc;',
- 'procedure DoIt(a: word);',
- 'begin',
- ' Func:=function(b:word): word',
- ' begin',
- ' Result:=a+b;',
- ' exit(b);',
- ' exit(Result);',
- ' end;',// test semicolon
- ' a:=3;',
- 'end;',
- 'begin',
- ' Func:=function(c:word):word begin',
- ' Result:=3+c;',
- ' exit(c);',
- ' exit(Result);',
- ' end;']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_Assign_ObjFPC',
- LinesToStr([ // statements
- 'this.Func = null;',
- 'this.DoIt = function (a) {',
- ' $mod.Func = function (b) {',
- ' var Result = 0;',
- ' Result = a + b;',
- ' return b;',
- ' return Result;',
- ' return Result;',
- ' };',
- ' a = 3;',
- '};',
- '']),
- LinesToStr([
- '$mod.Func = function (c) {',
- ' var Result = 0;',
- ' Result = 3 + c;',
- ' return c;',
- ' return Result;',
- ' return Result;',
- '};',
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_Assign_Delphi;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'type',
- ' TProc = reference to procedure(x: word);',
- 'procedure DoIt(a: word);',
- 'var Proc: TProc;',
- 'begin',
- ' Proc:=procedure(b:word) begin end;',
- 'end;',
- 'var Proc: TProc;',
- 'begin',
- ' Proc:=procedure(c:word) begin end;',
- '']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_Assign_Delphi',
- LinesToStr([ // statements
- 'this.DoIt = function (a) {',
- ' var Proc = null;',
- ' Proc = function (b) {',
- ' };',
- '};',
- 'this.Proc = null;',
- '']),
- LinesToStr([
- '$mod.Proc = function (c) {',
- '};',
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_Arg;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProc = reference to procedure;',
- ' TFunc = reference to function(x: word): word;',
- 'procedure DoMore(f,g: TProc);',
- 'begin',
- 'end;',
- 'procedure DoOdd(v: jsvalue);',
- 'begin',
- 'end;',
- 'procedure DoIt(f: TFunc);',
- 'begin',
- ' DoIt(function(b:word): word',
- ' begin',
- ' Result:=1+b;',
- ' end);',
- ' DoMore(procedure begin end, procedure begin end);',
- ' DoOdd(procedure begin end);',
- 'end;',
- 'begin',
- ' DoMore(procedure begin end,',
- ' procedure assembler asm',
- ' console.log("c");',
- ' end);',
- '']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_Arg',
- LinesToStr([ // statements
- 'this.DoMore = function (f, g) {',
- '};',
- 'this.DoOdd = function (v) {',
- '};',
- 'this.DoIt = function (f) {',
- ' $mod.DoIt(function (b) {',
- ' var Result = 0;',
- ' Result = 1 + b;',
- ' return Result;',
- ' });',
- ' $mod.DoMore(function () {',
- ' }, function () {',
- ' });',
- ' $mod.DoOdd(function () {',
- ' });',
- '};',
- '']),
- LinesToStr([
- '$mod.DoMore(function () {',
- '}, function () {',
- ' console.log("c");',
- '});',
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_Typecast;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProc = reference to procedure(w: word);',
- ' TArr = array of word;',
- ' TFuncArr = reference to function: TArr;',
- 'procedure DoIt(p: TProc);',
- 'var',
- ' w: word;',
- ' a: TArr;',
- 'begin',
- ' p:=TProc(procedure(b: smallint) begin end);',
- ' a:=TFuncArr(function: TArr begin end)();',
- ' w:=TFuncArr(function: TArr begin end)()[3];',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_Typecast',
- LinesToStr([ // statements
- 'this.DoIt = function (p) {',
- ' var w = 0;',
- ' var a = [];',
- ' p = function (b) {',
- ' };',
- ' a = function () {',
- ' var Result = [];',
- ' return Result;',
- ' }();',
- ' w = function () {',
- ' var Result = [];',
- ' return Result;',
- ' }()[3];',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_With;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProc = reference to procedure(w: word);',
- ' TObject = class',
- ' b: boolean;',
- ' end;',
- 'var',
- ' p: TProc;',
- ' bird: TObject;',
- 'begin',
- ' with bird do',
- ' p:=procedure(w: word)',
- ' begin',
- ' b:=w>2;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_With',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.b = false;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.p = null;',
- 'this.bird = null;',
- '']),
- LinesToStr([
- 'var $with = $mod.bird;',
- '$mod.p = function (w) {',
- ' $with.b = w > 2;',
- '};',
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_ExceptOn;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProc = reference to procedure;',
- ' TObject = class',
- ' b: boolean;',
- ' end;',
- 'procedure DoIt;',
- 'var',
- ' p: TProc;',
- 'begin',
- ' try',
- ' except',
- ' on E: TObject do',
- ' p:=procedure',
- ' begin',
- ' E.b:=true;',
- ' end;',
- ' end;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_ExceptOn',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.b = false;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.DoIt = function () {',
- ' var p = null;',
- ' try {} catch ($e) {',
- ' if ($mod.TObject.isPrototypeOf($e)) {',
- ' var E = $e;',
- ' p = function () {',
- ' E.b = true;',
- ' };',
- ' } else throw $e',
- ' };',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_Nested;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProc = reference to procedure;',
- ' TObject = class',
- ' i: byte;',
- ' procedure DoIt;',
- ' end;',
- 'procedure TObject.DoIt;',
- 'var',
- ' p: TProc;',
- ' procedure Sub;',
- ' begin',
- ' p:=procedure',
- ' begin',
- ' i:=3;',
- ' Self.i:=4;',
- ' p:=procedure',
- ' procedure SubSub;',
- ' begin',
- ' i:=13;',
- ' Self.i:=14;',
- ' end;',
- ' begin',
- ' i:=13;',
- ' Self.i:=14;',
- ' end;',
- ' end;',
- ' end;',
- 'begin',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_Nested',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.i = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' var $Self = this;',
- ' var p = null;',
- ' function Sub() {',
- ' p = function () {',
- ' $Self.i = 3;',
- ' $Self.i = 4;',
- ' p = function () {',
- ' function SubSub() {',
- ' $Self.i = 13;',
- ' $Self.i = 14;',
- ' };',
- ' $Self.i = 13;',
- ' $Self.i = 14;',
- ' };',
- ' };',
- ' };',
- ' };',
- '});',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_NestedAssignResult;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProc = reference to procedure;',
- 'function DoIt: TProc;',
- ' function Sub: TProc;',
- ' begin',
- ' Result:=procedure',
- ' begin',
- ' Sub:=procedure',
- ' procedure SubSub;',
- ' begin',
- ' Result:=nil;',
- ' Sub:=nil;',
- ' DoIt:=nil;',
- ' end;',
- ' begin',
- ' Result:=nil;',
- ' Sub:=nil;',
- ' DoIt:=nil;',
- ' end;',
- ' end;',
- ' end;',
- 'begin',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_NestedAssignResult',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' var Result = null;',
- ' function Sub() {',
- ' var Result$1 = null;',
- ' Result$1 = function () {',
- ' Result$1 = function () {',
- ' function SubSub() {',
- ' Result$1 = null;',
- ' Result$1 = null;',
- ' Result = null;',
- ' };',
- ' Result$1 = null;',
- ' Result$1 = null;',
- ' Result = null;',
- ' };',
- ' };',
- ' return Result$1;',
- ' };',
- ' return Result;',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_Class;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProc = reference to procedure;',
- ' TEvent = procedure of object;',
- ' TObject = class',
- ' Size: word;',
- ' function GetIt: TProc;',
- ' procedure DoIt; virtual; abstract;',
- ' end;',
- 'function TObject.GetIt: TProc;',
- 'begin',
- ' Result:=procedure',
- ' var p: TEvent;',
- ' begin',
- ' Size:=Size;',
- ' Size:=Self.Size;',
- ' p:=@DoIt;',
- ' p:[email protected];',
- ' end;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_Class',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Size = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetIt = function () {',
- ' var $Self = this;',
- ' var Result = null;',
- ' Result = function () {',
- ' var p = null;',
- ' $Self.Size = $Self.Size;',
- ' $Self.Size = $Self.Size;',
- ' p = rtl.createCallback($Self, "DoIt");',
- ' p = rtl.createCallback($Self, "DoIt");',
- ' };',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestAnonymousProc_ForLoop;
- begin
- StartProgram(false);
- Add([
- 'type TProc = reference to procedure;',
- 'procedure Foo(p: TProc);',
- 'begin',
- 'end;',
- 'procedure DoIt;',
- 'var i: word;',
- ' a: word;',
- 'begin',
- ' for i:=1 to 10 do begin',
- ' Foo(procedure begin a:=3; end);',
- ' end;',
- 'end;',
- 'begin',
- ' DoIt;']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_ForLoop',
- LinesToStr([ // statements
- 'this.Foo = function (p) {',
- '};',
- 'this.DoIt = function () {',
- ' var i = 0;',
- ' var a = 0;',
- ' for (i = 1; i <= 10; i++) {',
- ' $mod.Foo(function () {',
- ' a = 3;',
- ' });',
- ' };',
- '};',
- '']),
- LinesToStr([
- '$mod.DoIt();'
- ]));
- end;
- procedure TTestModule.TestAnonymousProc_AsmDelphi;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'type',
- ' TProc = reference to procedure;',
- ' TFunc = reference to function(x: word): word;',
- 'procedure Run;',
- 'asm',
- 'end;',
- 'procedure Walk(p: TProc; f: TFunc);',
- 'begin',
- ' Walk(procedure asm end, function(b:word): word asm return 1+b; end);',
- 'end;',
- 'begin',
- ' Walk(procedure',
- ' asm',
- ' console.log("a");',
- ' end,',
- ' function(x: word): word asm',
- ' console.log("c");',
- ' end);',
- '']);
- ConvertProgram;
- CheckSource('TestAnonymousProc_AsmDelphi',
- LinesToStr([ // statements
- 'this.Run = function () {',
- '};',
- 'this.Walk = function (p, f) {',
- ' $mod.Walk(function () {',
- ' }, function (b) {',
- ' return 1+b;',
- ' });',
- '};',
- '']),
- LinesToStr([
- '$mod.Walk(function () {',
- ' console.log("a");',
- '}, function (x) {',
- ' console.log("c");',
- '});',
- '']));
- end;
- procedure TTestModule.TestEnum_Name;
- begin
- StartProgram(false);
- Add('type TMyEnum = (Red, Green, Blue);');
- Add('var e: TMyEnum;');
- Add('var f: TMyEnum = Blue;');
- Add('begin');
- Add(' e:=green;');
- Add(' e:=default(TMyEnum);');
- ConvertProgram;
- CheckSource('TestEnum_Name',
- LinesToStr([ // statements
- 'this.TMyEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1,',
- ' "2":"Blue",',
- ' Blue:2',
- ' };',
- 'this.e = 0;',
- 'this.f = this.TMyEnum.Blue;'
- ]),
- LinesToStr([
- '$mod.e=$mod.TMyEnum.Green;',
- '$mod.e=$mod.TMyEnum.Red;'
- ]));
- end;
- procedure TTestModule.TestEnum_Number;
- begin
- Converter.Options:=Converter.Options+[coEnumNumbers];
- StartProgram(false);
- Add('type TMyEnum = (Red, Green);');
- Add('var');
- Add(' e: TMyEnum;');
- Add(' f: TMyEnum = Green;');
- Add(' i: longint;');
- Add('begin');
- Add(' e:=green;');
- Add(' i:=longint(e);');
- ConvertProgram;
- CheckSource('TestEnumNumber',
- LinesToStr([ // statements
- 'this.TMyEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1',
- ' };',
- 'this.e = 0;',
- 'this.f = 1;',
- 'this.i = 0;'
- ]),
- LinesToStr([
- '$mod.e=1;',
- '$mod.i=$mod.e;'
- ]));
- end;
- procedure TTestModule.TestEnum_ConstFail;
- begin
- StartProgram(false);
- Add([
- 'type TMyEnum = (Red = 100, Green = 101);',
- 'var',
- ' e: TMyEnum;',
- ' f: TMyEnum = Green;',
- 'begin',
- ' e:=green;']);
- SetExpectedPasResolverError('not yet implemented: Red:TPasEnumValue [20180126202434] "enum const"',3002);
- ConvertProgram;
- end;
- procedure TTestModule.TestEnum_Functions;
- begin
- StartProgram(false);
- Add([
- 'type TMyEnum = (Red, Green);',
- 'procedure DoIt(var e: TMyEnum; var i: word);',
- 'var',
- ' v: longint;',
- ' s: string;',
- 'begin',
- ' val(s,e,v);',
- ' val(s,e,i);',
- 'end;',
- 'var',
- ' e: TMyEnum;',
- ' i: longint;',
- ' s: string;',
- ' b: boolean;',
- 'begin',
- ' i:=ord(red);',
- ' i:=ord(green);',
- ' i:=ord(e);',
- ' i:=ord(b);',
- ' e:=low(tmyenum);',
- ' e:=low(e);',
- ' b:=low(boolean);',
- ' e:=high(tmyenum);',
- ' e:=high(e);',
- ' b:=high(boolean);',
- ' e:=pred(green);',
- ' e:=pred(e);',
- ' b:=pred(b);',
- ' e:=succ(red);',
- ' e:=succ(e);',
- ' b:=succ(b);',
- ' e:=tmyenum(1);',
- ' e:=tmyenum(i);',
- ' s:=str(e);',
- ' str(e,s);',
- ' str(red,s);',
- ' s:=str(e:3);',
- ' writestr(s,e:3,red);',
- ' val(s,e,i);',
- ' i:=longint(e);']);
- ConvertProgram;
- CheckSource('TestEnum_Functions',
- LinesToStr([ // statements
- 'this.TMyEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1',
- ' };',
- 'this.DoIt = function (e, i) {',
- ' var v = 0;',
- ' var s = "";',
- ' e.set(rtl.valEnum(s, $mod.TMyEnum, function (w) {',
- ' v = w;',
- ' }));',
- ' e.set(rtl.valEnum(s, $mod.TMyEnum, i.set));',
- '};',
- 'this.e = 0;',
- 'this.i = 0;',
- 'this.s = "";',
- 'this.b = false;',
- '']),
- LinesToStr([
- '$mod.i=$mod.TMyEnum.Red;',
- '$mod.i=$mod.TMyEnum.Green;',
- '$mod.i=$mod.e;',
- '$mod.i=$mod.b+0;',
- '$mod.e=$mod.TMyEnum.Red;',
- '$mod.e=$mod.TMyEnum.Red;',
- '$mod.b=false;',
- '$mod.e=$mod.TMyEnum.Green;',
- '$mod.e=$mod.TMyEnum.Green;',
- '$mod.b=true;',
- '$mod.e=$mod.TMyEnum.Green-1;',
- '$mod.e=$mod.e-1;',
- '$mod.b=false;',
- '$mod.e=$mod.TMyEnum.Red+1;',
- '$mod.e=$mod.e+1;',
- '$mod.b=true;',
- '$mod.e=1;',
- '$mod.e=$mod.i;',
- '$mod.s = $mod.TMyEnum[$mod.e];',
- '$mod.s = $mod.TMyEnum[$mod.e];',
- '$mod.s = $mod.TMyEnum[$mod.TMyEnum.Red];',
- '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3);',
- '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3)+$mod.TMyEnum[$mod.TMyEnum.Red];',
- '$mod.e = rtl.valEnum($mod.s, $mod.TMyEnum, function (v) {',
- ' $mod.i = v;',
- '});',
- '$mod.i=$mod.e;',
- '']));
- end;
- procedure TTestModule.TestEnumRg_Functions;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (Red, Green, Blue);',
- ' TEnumRg = Green..Blue;',
- 'procedure DoIt(var e: TEnumRg; var i: word);',
- 'var',
- ' v: longint;',
- ' s: string;',
- 'begin',
- ' val(s,e,v);',
- ' val(s,e,i);',
- 'end;',
- 'var',
- ' e: TEnumRg;',
- ' i: longint;',
- ' s: string;',
- 'begin',
- ' i:=ord(green);',
- ' i:=ord(e);',
- ' e:=low(tenumrg);',
- ' e:=low(e);',
- ' e:=high(tenumrg);',
- ' e:=high(e);',
- ' e:=pred(blue);',
- ' e:=pred(e);',
- ' e:=succ(green);',
- ' e:=succ(e);',
- ' e:=tenumrg(1);',
- ' e:=tenumrg(i);',
- ' s:=str(e);',
- ' str(e,s);',
- ' str(red,s);',
- ' s:=str(e:3);',
- ' writestr(s,e:3,blue);',
- ' val(s,e,i);',
- ' i:=longint(e);']);
- ConvertProgram;
- CheckSource('TestEnumRg_Functions',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1,',
- ' "2":"Blue",',
- ' Blue:2',
- ' };',
- 'this.DoIt = function (e, i) {',
- ' var v = 0;',
- ' var s = "";',
- ' e.set(rtl.valEnum(s, $mod.TEnum, function (w) {',
- ' v = w;',
- ' }));',
- ' e.set(rtl.valEnum(s, $mod.TEnum, i.set));',
- '};',
- 'this.e = this.TEnum.Green;',
- 'this.i = 0;',
- 'this.s = "";',
- '']),
- LinesToStr([
- '$mod.i=$mod.TEnum.Green;',
- '$mod.i=$mod.e;',
- '$mod.e=$mod.TEnum.Green;',
- '$mod.e=$mod.TEnum.Green;',
- '$mod.e=$mod.TEnum.Blue;',
- '$mod.e=$mod.TEnum.Blue;',
- '$mod.e=$mod.TEnum.Blue-1;',
- '$mod.e=$mod.e-1;',
- '$mod.e=$mod.TEnum.Green+1;',
- '$mod.e=$mod.e+1;',
- '$mod.e=1;',
- '$mod.e=$mod.i;',
- '$mod.s = $mod.TEnum[$mod.e];',
- '$mod.s = $mod.TEnum[$mod.e];',
- '$mod.s = $mod.TEnum[$mod.TEnum.Red];',
- '$mod.s = rtl.spaceLeft($mod.TEnum[$mod.e], 3);',
- '$mod.s = rtl.spaceLeft($mod.TEnum[$mod.e], 3)+$mod.TEnum[$mod.TEnum.Blue];',
- '$mod.e = rtl.valEnum($mod.s, $mod.TEnum, function (v) {',
- ' $mod.i = v;',
- '});',
- '$mod.i=$mod.e;',
- '']));
- end;
- procedure TTestModule.TestEnum_AsParams;
- begin
- StartProgram(false);
- Add('type TEnum = (Red,Blue);');
- Add('procedure DoIt(vG: TEnum; const vH: TEnum; var vI: TEnum);');
- Add('var vJ: TEnum;');
- Add('begin');
- Add(' vg:=vg;');
- Add(' vj:=vh;');
- Add(' vi:=vi;');
- Add(' doit(vg,vg,vg);');
- Add(' doit(vh,vh,vj);');
- Add(' doit(vi,vi,vi);');
- Add(' doit(vj,vj,vj);');
- Add('end;');
- Add('var i: TEnum;');
- Add('begin');
- Add(' doit(i,i,i);');
- ConvertProgram;
- CheckSource('TestEnum_AsParams',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "Red",',
- ' Red: 0,',
- ' "1": "Blue",',
- ' Blue: 1',
- '};',
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = 0;',
- ' vG = vG;',
- ' vJ = vH;',
- ' vI.set(vI.get());',
- ' $mod.DoIt(vG, vG, {',
- ' get: function () {',
- ' return vG;',
- ' },',
- ' set: function (v) {',
- ' vG = v;',
- ' }',
- ' });',
- ' $mod.DoIt(vH, vH, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- ' $mod.DoIt(vI.get(), vI.get(), vI);',
- ' $mod.DoIt(vJ, vJ, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- '};',
- 'this.i = 0;'
- ]),
- LinesToStr([
- '$mod.DoIt($mod.i,$mod.i,{',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});'
- ]));
- end;
- procedure TTestModule.TestEnumRange_Array;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (Red, Green, Blue);',
- ' TEnumRg = green..blue;',
- ' TArr = array[TEnumRg] of byte;',
- ' TArr2 = array[green..blue] of byte;',
- 'var',
- ' a: TArr;',
- ' b: TArr = (3,4);',
- ' c: TArr2 = (5,6);',
- 'begin',
- ' a[green] := b[blue];',
- ' c[green] := c[blue];',
- '']);
- ConvertProgram;
- CheckSource('TestEnumRange_Array',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "Red",',
- ' Red: 0,',
- ' "1": "Green",',
- ' Green: 1,',
- ' "2": "Blue",',
- ' Blue: 2',
- '};',
- 'this.a = rtl.arraySetLength(null, 0, 2);',
- 'this.b = [3, 4];',
- 'this.c = [5, 6];',
- '']),
- LinesToStr([
- ' $mod.a[$mod.TEnum.Green - 1] = $mod.b[$mod.TEnum.Blue - 1];',
- ' $mod.c[$mod.TEnum.Green - 1] = $mod.c[$mod.TEnum.Blue - 1];',
- '']));
- end;
- procedure TTestModule.TestEnum_ForIn;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (Red, Green, Blue);',
- ' TEnumRg = green..blue;',
- ' TArr = array[TEnum] of byte;',
- ' TArrRg = array[TEnumRg] of byte;',
- 'var',
- ' e: TEnum;',
- ' a1: TArr = (3,4,5);',
- ' a2: TArrRg = (11,12);',
- ' b: byte;',
- 'begin',
- ' for e in TEnum do ;',
- ' for e in TEnumRg do ;',
- ' for e in TArr do ;',
- ' for e in TArrRg do ;',
- ' for b in a1 do ;',
- ' for b in a2 do ;',
- '']);
- ConvertProgram;
- CheckSource('TestEnum_ForIn',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "Red",',
- ' Red: 0,',
- ' "1": "Green",',
- ' Green: 1,',
- ' "2": "Blue",',
- ' Blue: 2',
- '};',
- 'this.e = 0;',
- 'this.a1 = [3, 4, 5];',
- 'this.a2 = [11, 12];',
- 'this.b = 0;',
- '']),
- LinesToStr([
- ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
- ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
- ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
- ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
- ' for (var $in = $mod.a1, $l = 0, $end = rtl.length($in) - 1; $l <= $end; $l++) $mod.b = $in[$l];',
- ' for (var $in1 = $mod.a2, $l1 = 0, $end1 = rtl.length($in1) - 1; $l1 <= $end1; $l1++) $mod.b = $in1[$l1];',
- '']));
- end;
- procedure TTestModule.TestEnum_ScopedNumber;
- begin
- Converter.Options:=Converter.Options+[coEnumNumbers];
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (Red, Green);',
- 'var',
- ' e: TEnum;',
- 'begin',
- ' e:=TEnum.Green;',
- '']);
- ConvertProgram;
- CheckSource('TestEnum_ScopedNumber',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "Red",',
- ' Red: 0,',
- ' "1": "Green",',
- ' Green: 1',
- '};',
- 'this.e = 0;',
- '']),
- LinesToStr([
- '$mod.e = 1;']));
- end;
- procedure TTestModule.TestEnum_InFunction;
- begin
- StartProgram(false);
- Add([
- 'const TEnum = 3;',
- 'procedure DoIt;',
- 'type',
- ' TEnum = (Red, Green, Blue);',
- ' procedure Sub;',
- ' type',
- ' TEnumSub = (Left, Right);',
- ' var',
- ' es: TEnumSub;',
- ' begin',
- ' es:=Left;',
- ' end;',
- 'var',
- ' e, e2: TEnum;',
- 'begin',
- ' if e in [red,blue] then e2:=e;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestEnum_InFunction',
- LinesToStr([ // statements
- 'this.TEnum = 3;',
- 'var TEnum$1 = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1,',
- ' "2":"Blue",',
- ' Blue:2',
- ' };',
- 'var TEnumSub = {',
- ' "0": "Left",',
- ' Left: 0,',
- ' "1": "Right",',
- ' Right: 1',
- '};',
- 'this.DoIt = function () {',
- ' function Sub() {',
- ' var es = 0;',
- ' es = TEnumSub.Left;',
- ' };',
- ' var e = 0;',
- ' var e2 = 0;',
- ' if (e in rtl.createSet(TEnum$1.Red, TEnum$1.Blue)) e2 = e;',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestEnum_Name_Anonymous_Unit;
- begin
- StartUnit(true);
- Add([
- 'interface',
- 'var color: (red, green);',
- 'implementation',
- 'initialization',
- ' color:=green;',
- '']);
- ConvertUnit;
- CheckSource('TestEnum_Name_Anonymous_Unit',
- LinesToStr([
- 'this.color$a = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "green",',
- ' green: 1',
- '};',
- 'this.color = 0;',
- '']),
- LinesToStr([ // this.$init
- '$mod.color = $mod.color$a.green;',
- '']),
- LinesToStr([ // implementation
- '']) );
- end;
- procedure TTestModule.TestSet_Enum;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TColor = (Red, Green, Blue);',
- ' TColors = set of TColor;',
- 'var',
- ' c: TColor;',
- ' s: TColors;',
- ' t: TColors = [];',
- ' u: TColors = [Red];',
- 'begin',
- ' s:=[];',
- ' s:=[Green];',
- ' s:=[Green,Blue];',
- ' s:=[Red..Blue];',
- ' s:=[Red,Green..Blue];',
- ' s:=[Red,c];',
- ' s:=t;',
- ' s:=default(TColors);',
- '']);
- ConvertProgram;
- CheckSource('TestSet',
- LinesToStr([ // statements
- 'this.TColor = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1,',
- ' "2":"Blue",',
- ' Blue:2',
- ' };',
- 'this.c = 0;',
- 'this.s = {};',
- 'this.t = {};',
- 'this.u = rtl.createSet(this.TColor.Red);'
- ]),
- LinesToStr([
- '$mod.s={};',
- '$mod.s=rtl.createSet($mod.TColor.Green);',
- '$mod.s=rtl.createSet($mod.TColor.Green,$mod.TColor.Blue);',
- '$mod.s=rtl.createSet(null,$mod.TColor.Red,$mod.TColor.Blue);',
- '$mod.s=rtl.createSet($mod.TColor.Red,null,$mod.TColor.Green,$mod.TColor.Blue);',
- '$mod.s=rtl.createSet($mod.TColor.Red,$mod.c);',
- '$mod.s=rtl.refSet($mod.t);',
- '$mod.s={};',
- '']));
- end;
- procedure TTestModule.TestSet_Operators;
- begin
- StartProgram(false);
- Add('type');
- Add(' TColor = (Red, Green, Blue);');
- Add(' TColors = set of tcolor;');
- Add('var');
- Add(' vC: TColor;');
- Add(' vS: TColors;');
- Add(' vT: TColors;');
- Add(' vU: TColors;');
- Add(' B: boolean;');
- Add('begin');
- Add(' include(vs,green);');
- Add(' exclude(vs,vc);');
- Add(' vs:=vt+vu;');
- Add(' vs:=vt+[red];');
- Add(' vs:=[red]+vt;');
- Add(' vs:=[red]+[green];');
- Add(' vs:=vt-vu;');
- Add(' vs:=vt-[red];');
- Add(' vs:=[red]-vt;');
- Add(' vs:=[red]-[green];');
- Add(' vs:=vt*vu;');
- Add(' vs:=vt*[red];');
- Add(' vs:=[red]*vt;');
- Add(' vs:=[red]*[green];');
- Add(' vs:=vt><vu;');
- Add(' vs:=vt><[red];');
- Add(' vs:=[red]><vt;');
- Add(' vs:=[red]><[green];');
- Add(' b:=vt=vu;');
- Add(' b:=vt=[red];');
- Add(' b:=[red]=vt;');
- Add(' b:=[red]=[green];');
- Add(' b:=vt<>vu;');
- Add(' b:=vt<>[red];');
- Add(' b:=[red]<>vt;');
- Add(' b:=[red]<>[green];');
- Add(' b:=vt<=vu;');
- Add(' b:=vt<=[red];');
- Add(' b:=[red]<=vt;');
- Add(' b:=[red]<=[green];');
- Add(' b:=vt>=vu;');
- Add(' b:=vt>=[red];');
- Add(' b:=[red]>=vt;');
- Add(' b:=[red]>=[green];');
- ConvertProgram;
- CheckSource('TestSet_Operators',
- LinesToStr([ // statements
- 'this.TColor = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1,',
- ' "2":"Blue",',
- ' Blue:2',
- ' };',
- 'this.vC = 0;',
- 'this.vS = {};',
- 'this.vT = {};',
- 'this.vU = {};',
- 'this.B = false;'
- ]),
- LinesToStr([
- '$mod.vS = rtl.includeSet($mod.vS,$mod.TColor.Green);',
- '$mod.vS = rtl.excludeSet($mod.vS,$mod.vC);',
- '$mod.vS = rtl.unionSet($mod.vT, $mod.vU);',
- '$mod.vS = rtl.unionSet($mod.vT, rtl.createSet($mod.TColor.Red));',
- '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
- '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
- '$mod.vS = rtl.diffSet($mod.vT, $mod.vU);',
- '$mod.vS = rtl.diffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
- '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
- '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
- '$mod.vS = rtl.intersectSet($mod.vT, $mod.vU);',
- '$mod.vS = rtl.intersectSet($mod.vT, rtl.createSet($mod.TColor.Red));',
- '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
- '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
- '$mod.vS = rtl.symDiffSet($mod.vT, $mod.vU);',
- '$mod.vS = rtl.symDiffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
- '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
- '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
- '$mod.B = rtl.eqSet($mod.vT, $mod.vU);',
- '$mod.B = rtl.eqSet($mod.vT, rtl.createSet($mod.TColor.Red));',
- '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
- '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
- '$mod.B = rtl.neSet($mod.vT, $mod.vU);',
- '$mod.B = rtl.neSet($mod.vT, rtl.createSet($mod.TColor.Red));',
- '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
- '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
- '$mod.B = rtl.leSet($mod.vT, $mod.vU);',
- '$mod.B = rtl.leSet($mod.vT, rtl.createSet($mod.TColor.Red));',
- '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
- '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
- '$mod.B = rtl.geSet($mod.vT, $mod.vU);',
- '$mod.B = rtl.geSet($mod.vT, rtl.createSet($mod.TColor.Red));',
- '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
- '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
- '']));
- end;
- procedure TTestModule.TestSet_Operator_In;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TColor = (Red, Green, Blue);',
- ' TColors = set of tcolor;',
- ' TColorRg = green..blue;',
- 'var',
- ' vC: tcolor;',
- ' vT: tcolors;',
- ' B: boolean;',
- ' rg: TColorRg;',
- 'begin',
- ' b:=red in vt;',
- ' b:=vc in vt;',
- ' b:=green in [red..blue];',
- ' b:=vc in [red..blue];',
- ' ',
- ' if red in vt then ;',
- ' while vC in vt do ;',
- ' repeat',
- ' until vC in vt;',
- ' if rg in [green..blue] then ;',
- '']);
- ConvertProgram;
- CheckSource('TestSet_Operator_In',
- LinesToStr([ // statements
- 'this.TColor = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1,',
- ' "2":"Blue",',
- ' Blue:2',
- ' };',
- 'this.vC = 0;',
- 'this.vT = {};',
- 'this.B = false;',
- 'this.rg = this.TColor.Green;',
- '']),
- LinesToStr([
- '$mod.B = $mod.TColor.Red in $mod.vT;',
- '$mod.B = $mod.vC in $mod.vT;',
- '$mod.B = $mod.TColor.Green in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
- '$mod.B = $mod.vC in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
- 'if ($mod.TColor.Red in $mod.vT) ;',
- 'while ($mod.vC in $mod.vT) {',
- '};',
- 'do {',
- '} while (!($mod.vC in $mod.vT));',
- 'if ($mod.rg in rtl.createSet(null, $mod.TColor.Green, $mod.TColor.Blue)) ;',
- '']));
- end;
- procedure TTestModule.TestSet_Functions;
- begin
- StartProgram(false);
- Add('type');
- Add(' TMyEnum = (Red, Green);');
- Add(' TMyEnums = set of TMyEnum;');
- Add('var');
- Add(' e: TMyEnum;');
- Add(' s: TMyEnums;');
- Add('begin');
- Add(' e:=Low(TMyEnums);');
- Add(' e:=Low(s);');
- Add(' e:=High(TMyEnums);');
- Add(' e:=High(s);');
- ConvertProgram;
- CheckSource('TestSetFunctions',
- LinesToStr([ // statements
- 'this.TMyEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1',
- ' };',
- 'this.e = 0;',
- 'this.s = {};'
- ]),
- LinesToStr([
- '$mod.e=$mod.TMyEnum.Red;',
- '$mod.e=$mod.TMyEnum.Red;',
- '$mod.e=$mod.TMyEnum.Green;',
- '$mod.e=$mod.TMyEnum.Green;',
- '']));
- end;
- procedure TTestModule.TestSet_PassAsArgClone;
- begin
- StartProgram(false);
- Add('type');
- Add(' TMyEnum = (Red, Green);');
- Add(' TMyEnums = set of TMyEnum;');
- Add('procedure DoDefault(s: tmyenums); begin end;');
- Add('procedure DoConst(const s: tmyenums); begin end;');
- Add('var');
- Add(' aSet: tmyenums;');
- Add('begin');
- Add(' dodefault(aset);');
- Add(' doconst(aset);');
- ConvertProgram;
- CheckSource('TestSetFunctions',
- LinesToStr([ // statements
- 'this.TMyEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1',
- ' };',
- 'this.DoDefault = function (s) {',
- '};',
- 'this.DoConst = function (s) {',
- '};',
- 'this.aSet = {};'
- ]),
- LinesToStr([
- '$mod.DoDefault(rtl.refSet($mod.aSet));',
- '$mod.DoConst($mod.aSet);',
- '']));
- end;
- procedure TTestModule.TestSet_AsParams;
- begin
- StartProgram(false);
- Add([
- 'type TEnum = (Red,Blue);',
- 'type TEnums = set of TEnum;',
- 'function DoIt(vG: TEnums; const vH: TEnums; var vI: TEnums): TEnums;',
- 'var vJ: TEnums;',
- 'begin',
- ' Include(vg,red);',
- ' Include(result,blue);',
- ' vg:=vg;',
- ' vj:=vh;',
- ' vi:=vi;',
- ' doit(vg,vg,vg);',
- ' doit(vh,vh,vj);',
- ' doit(vi,vi,vi);',
- ' doit(vj,vj,vj);',
- 'end;',
- 'var i: TEnums;',
- 'begin',
- ' doit(i,i,i);']);
- ConvertProgram;
- CheckSource('TestSet_AsParams',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "Red",',
- ' Red: 0,',
- ' "1": "Blue",',
- ' Blue: 1',
- '};',
- 'this.DoIt = function (vG,vH,vI) {',
- ' var Result = {};',
- ' var vJ = {};',
- ' vG = rtl.includeSet(vG, $mod.TEnum.Red);',
- ' Result = rtl.includeSet(Result, $mod.TEnum.Blue);',
- ' vG = rtl.refSet(vG);',
- ' vJ = rtl.refSet(vH);',
- ' vI.set(rtl.refSet(vI.get()));',
- ' $mod.DoIt(rtl.refSet(vG), vG, {',
- ' get: function () {',
- ' return vG;',
- ' },',
- ' set: function (v) {',
- ' vG = v;',
- ' }',
- ' });',
- ' $mod.DoIt(rtl.refSet(vH), vH, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- ' $mod.DoIt(rtl.refSet(vI.get()), vI.get(), vI);',
- ' $mod.DoIt(rtl.refSet(vJ), vJ, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- ' return Result;',
- '};',
- 'this.i = {};'
- ]),
- LinesToStr([
- '$mod.DoIt(rtl.refSet($mod.i),$mod.i,{',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});'
- ]));
- end;
- procedure TTestModule.TestSet_Property;
- begin
- StartProgram(false);
- Add('type');
- Add(' TEnum = (Red,Blue);');
- Add(' TEnums = set of TEnum;');
- Add(' TObject = class');
- Add(' function GetColors: TEnums; external name ''GetColors'';');
- Add(' procedure SetColors(const Value: TEnums); external name ''SetColors'';');
- Add(' property Colors: TEnums read GetColors write SetColors;');
- Add(' end;');
- Add('procedure DoIt(i: TEnums; const j: TEnums; var k: TEnums; out l: TEnums);');
- Add('begin end;');
- Add('var Obj: TObject;');
- Add('begin');
- Add(' Include(Obj.Colors,Red);');
- Add(' Exclude(Obj.Colors,Red);');
- //Add(' DoIt(Obj.Colors,Obj.Colors,Obj.Colors,Obj.Colors);');
- ConvertProgram;
- CheckSource('TestSet_Property',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "Red",',
- ' Red: 0,',
- ' "1": "Blue",',
- ' Blue: 1',
- '};',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.DoIt = function (i, j, k, l) {',
- '};',
- 'this.Obj = null;',
- '']),
- LinesToStr([
- '$mod.Obj.SetColors(rtl.includeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
- '$mod.Obj.SetColors(rtl.excludeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
- '']));
- end;
- procedure TTestModule.TestSet_EnumConst;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (Red,Blue);',
- ' TEnums = set of TEnum;',
- 'const',
- ' Orange = red;',
- 'var',
- ' Enum: tenum;',
- ' Enums: tenums;',
- 'begin',
- ' Include(enums,orange);',
- ' Exclude(enums,orange);',
- ' if orange in enums then;',
- ' if orange in [orange,red] then;']);
- ConvertProgram;
- CheckSource('TestSet_EnumConst',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "Red",',
- ' Red: 0,',
- ' "1": "Blue",',
- ' Blue: 1',
- '};',
- 'this.Orange = this.TEnum.Red;',
- 'this.Enum = 0;',
- 'this.Enums = {};',
- '']),
- LinesToStr([
- '$mod.Enums = rtl.includeSet($mod.Enums, $mod.TEnum.Red);',
- '$mod.Enums = rtl.excludeSet($mod.Enums, $mod.TEnum.Red);',
- 'if ($mod.TEnum.Red in $mod.Enums) ;',
- 'if ($mod.TEnum.Red in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Red)) ;',
- '']));
- end;
- procedure TTestModule.TestSet_IntConst;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnums = set of Byte;',
- 'const',
- ' Orange = 0;',
- 'var',
- ' Enum: byte;',
- ' Enums: tenums;',
- 'begin',
- ' Enums:=[];',
- ' Enums:=[0];',
- ' Enums:=[1..2];',
- //' Include(enums,orange);',
- //' Exclude(enums,orange);',
- ' if orange in enums then;',
- ' if orange in [orange,1] then;']);
- ConvertProgram;
- CheckSource('TestSet_IntConst',
- LinesToStr([ // statements
- 'this.Orange = 0;',
- 'this.Enum = 0;',
- 'this.Enums = {};',
- '']),
- LinesToStr([
- '$mod.Enums = {};',
- '$mod.Enums = rtl.createSet(0);',
- '$mod.Enums = rtl.createSet(null, 1, 2);',
- 'if (0 in $mod.Enums) ;',
- 'if (0 in rtl.createSet(0, 1)) ;',
- '']));
- end;
- procedure TTestModule.TestSet_IntRange;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TRange = 1..3;',
- ' TEnums = set of TRange;',
- 'const',
- ' Orange = 2;',
- 'var',
- ' Enum: byte;',
- ' Enums: TEnums;',
- 'begin',
- ' Enums:=[];',
- ' Enums:=[1];',
- ' Enums:=[2..3];',
- ' Include(enums,orange);',
- ' Exclude(enums,orange);',
- ' if orange in enums then;',
- ' if orange in [orange,1] then;']);
- ConvertProgram;
- CheckSource('TestSet_IntRange',
- LinesToStr([ // statements
- 'this.Orange = 2;',
- 'this.Enum = 0;',
- 'this.Enums = {};',
- '']),
- LinesToStr([
- '$mod.Enums = {};',
- '$mod.Enums = rtl.createSet(1);',
- '$mod.Enums = rtl.createSet(null, 2, 3);',
- '$mod.Enums = rtl.includeSet($mod.Enums, 2);',
- '$mod.Enums = rtl.excludeSet($mod.Enums, 2);',
- 'if (2 in $mod.Enums) ;',
- 'if (2 in rtl.createSet(2, 1)) ;',
- '']));
- end;
- procedure TTestModule.TestSet_AnonymousEnumType;
- begin
- StartProgram(false);
- Add('type');
- Add(' TFlags = set of (red, green);');
- Add('const');
- Add(' favorite = red;');
- Add('var');
- Add(' f: TFlags;');
- Add(' i: longint;');
- Add('begin');
- Add(' Include(f,red);');
- Add(' Include(f,favorite);');
- Add(' i:=ord(red);');
- Add(' i:=ord(favorite);');
- Add(' i:=ord(low(TFlags));');
- Add(' i:=ord(low(f));');
- Add(' i:=ord(low(favorite));');
- Add(' i:=ord(high(TFlags));');
- Add(' i:=ord(high(f));');
- Add(' i:=ord(high(favorite));');
- Add(' f:=[green,favorite];');
- ConvertProgram;
- CheckSource('TestSet_AnonymousEnumType',
- LinesToStr([ // statements
- 'this.TFlags$a = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "green",',
- ' green: 1',
- '};',
- 'this.favorite = this.TFlags$a.red;',
- 'this.f = {};',
- 'this.i = 0;',
- '']),
- LinesToStr([
- '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
- '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
- '$mod.i = $mod.TFlags$a.red;',
- '$mod.i = $mod.TFlags$a.red;',
- '$mod.i = $mod.TFlags$a.red;',
- '$mod.i = $mod.TFlags$a.red;',
- '$mod.i = $mod.TFlags$a.red;',
- '$mod.i = $mod.TFlags$a.green;',
- '$mod.i = $mod.TFlags$a.green;',
- '$mod.i = $mod.TFlags$a.green;',
- '$mod.f = rtl.createSet($mod.TFlags$a.green, $mod.TFlags$a.red);',
- '']));
- end;
- procedure TTestModule.TestSet_AnonymousEnumTypeChar;
- begin
- exit;
- StartProgram(false);
- Add([
- 'type',
- ' TAtoZ = ''A''..''Z'';',
- ' TSetOfAZ = set of TAtoZ;',
- 'var',
- ' c: char;',
- ' a: TAtoZ;',
- ' s: TSetOfAZ = [''P'',''A''];',
- ' i: longint;',
- 'begin',
- ' Include(s,''S'');',
- ' Include(s,c);',
- ' Include(s,a);',
- ' c:=low(TAtoZ);',
- ' i:=ord(low(TAtoZ));',
- ' a:=high(TAtoZ);',
- ' a:=high(TSetOfAtoZ);',
- ' s:=[a,c,''M''];',
- '']);
- ConvertProgram;
- CheckSource('TestSet_AnonymousEnumTypeChar',
- LinesToStr([ // statements
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestSet_ConstEnum;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (red,blue,green);',
- ' TEnums = set of TEnum;',
- 'const',
- ' teAny = [low(TEnum)..high(TEnum)];',
- ' teRedBlue = [low(TEnum)..pred(high(TEnum))];',
- 'var',
- ' e: TEnum;',
- ' s: TEnums;',
- 'begin',
- ' if blue in teAny then;',
- ' if blue in teAny+[e] then;',
- ' if blue in teAny+teRedBlue then;',
- ' if e in [red,blue] then;',
- ' s:=teAny;',
- ' s:=teAny+[e];',
- ' s:=[e]+teAny;',
- ' s:=teAny+teRedBlue;',
- ' s:=teAny+teRedBlue+[e];',
- '']);
- ConvertProgram;
- CheckSource('TestSet_ConstEnum',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1,',
- ' "2": "green",',
- ' green: 2',
- '};',
- 'this.teAny = rtl.createSet(null, this.TEnum.red, this.TEnum.green);',
- 'this.teRedBlue = rtl.createSet(null, this.TEnum.red, this.TEnum.green - 1);',
- 'this.e = 0;',
- 'this.s = {};',
- '']),
- LinesToStr([
- 'if ($mod.TEnum.blue in $mod.teAny) ;',
- 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, rtl.createSet($mod.e))) ;',
- 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, $mod.teRedBlue)) ;',
- 'if ($mod.e in rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)) ;',
- '$mod.s = rtl.refSet($mod.teAny);',
- '$mod.s = rtl.unionSet($mod.teAny, rtl.createSet($mod.e));',
- '$mod.s = rtl.unionSet(rtl.createSet($mod.e), $mod.teAny);',
- '$mod.s = rtl.unionSet($mod.teAny, $mod.teRedBlue);',
- '$mod.s = rtl.unionSet(rtl.unionSet($mod.teAny, $mod.teRedBlue), rtl.createSet($mod.e));',
- '']));
- end;
- procedure TTestModule.TestSet_ConstChar;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' LowChars = [''a''..''z''];',
- ' Chars = LowChars+[''A''..''Z''];',
- ' sc = [''А'', ''Я''];',
- 'var',
- ' c: char;',
- ' s: string;',
- 'begin',
- ' if c in lowchars then ;',
- ' if ''a'' in lowchars then ;',
- ' if s[1] in lowchars then ;',
- ' if c in chars then ;',
- ' if c in [''a''..''z'',''_''] then ;',
- ' if ''b'' in [''a''..''z'',''_''] then ;',
- ' if ''Я'' in sc then ;',
- ' if 3=ord('' '') then ;',
- '']);
- ConvertProgram;
- CheckSource('TestSet_ConstChar',
- LinesToStr([ // statements
- 'this.LowChars = rtl.createSet(null, 97, 122);',
- 'this.Chars = rtl.unionSet(this.LowChars, rtl.createSet(null, 65, 90));',
- 'this.sc = rtl.createSet(1040, 1071);',
- 'this.c = "";',
- 'this.s = "";',
- '']),
- LinesToStr([
- 'if ($mod.c.charCodeAt() in $mod.LowChars) ;',
- 'if (97 in $mod.LowChars) ;',
- 'if ($mod.s.charCodeAt(0) in $mod.LowChars) ;',
- 'if ($mod.c.charCodeAt() in $mod.Chars) ;',
- 'if ($mod.c.charCodeAt() in rtl.createSet(null, 97, 122, 95)) ;',
- 'if (98 in rtl.createSet(null, 97, 122, 95)) ;',
- 'if (1071 in $mod.sc) ;',
- 'if (3 === 32) ;',
- '']));
- end;
- procedure TTestModule.TestSet_ConstInt;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' Months = [1..12];',
- ' Mirror = [-12..-1]+Months;',
- 'var',
- ' i: smallint;',
- 'begin',
- ' if 3 in Months then;',
- ' if i in Months+[i] then;',
- ' if i in Months+Mirror then;',
- ' if i in [4..6,8] then;',
- '']);
- ConvertProgram;
- CheckSource('TestSet_ConstInt',
- LinesToStr([ // statements
- 'this.Months = rtl.createSet(null, 1, 12);',
- 'this.Mirror = rtl.unionSet(rtl.createSet(null, -12, -1), this.Months);',
- 'this.i = 0;',
- '']),
- LinesToStr([
- 'if (3 in $mod.Months) ;',
- 'if ($mod.i in rtl.unionSet($mod.Months, rtl.createSet($mod.i))) ;',
- 'if ($mod.i in rtl.unionSet($mod.Months, $mod.Mirror)) ;',
- 'if ($mod.i in rtl.createSet(null, 4, 6, 8)) ;',
- '']));
- end;
- procedure TTestModule.TestSet_InFunction;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' TEnum = 3;',
- ' TSetOfEnum = 4;',
- ' TSetOfAno = 5;',
- 'procedure DoIt;',
- 'type',
- ' TEnum = (red, blue);',
- ' TSetOfEnum = set of TEnum;',
- ' TSetOfAno = set of (up,down);',
- 'var',
- ' e: TEnum;',
- ' se: TSetOfEnum;',
- ' sa: TSetOfAno;',
- 'begin',
- ' se:=[e];',
- ' sa:=[up];',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestSet_InFunction',
- LinesToStr([ // statements
- 'this.TEnum = 3;',
- 'this.TSetOfEnum = 4;',
- 'this.TSetOfAno = 5;',
- 'var TEnum$1 = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'var TSetOfAno$a = {',
- ' "0": "up",',
- ' up: 0,',
- ' "1": "down",',
- ' down: 1',
- '};',
- 'this.DoIt = function () {',
- ' var e = 0;',
- ' var se = {};',
- ' var sa = {};',
- ' se = rtl.createSet(e);',
- ' sa = rtl.createSet(TSetOfAno$a.up);',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestSet_ForIn;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (Red, Green, Blue);',
- ' TEnumRg = green..blue;',
- ' TSetOfEnum = set of TEnum;',
- ' TSetOfEnumRg = set of TEnumRg;',
- 'var',
- ' e, e2: TEnum;',
- ' er: TEnum;',
- ' s: TSetOfEnum;',
- 'begin',
- ' for e in TSetOfEnum do ;',
- ' for e in TSetOfEnumRg do ;',
- ' for e in [] do e2:=e;',
- ' for e in [red..green] do e2:=e;',
- ' for e in [green,blue] do e2:=e;',
- ' for e in [red,blue] do e2:=e;',
- ' for e in s do e2:=e;',
- ' for er in TSetOfEnumRg do ;',
- '']);
- ConvertProgram;
- CheckSource('TestSet_ForIn',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1,',
- ' "2":"Blue",',
- ' Blue:2',
- ' };',
- 'this.e = 0;',
- 'this.e2 = 0;',
- 'this.er = 0;',
- 'this.s = {};',
- '']),
- LinesToStr([
- 'for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
- 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
- 'for ($mod.e = 0; $mod.e <= 1; $mod.e++) $mod.e2 = $mod.e;',
- 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) $mod.e2 = $mod.e;',
- 'for ($mod.e in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Blue)) $mod.e2 = $mod.e;',
- 'for (var $l in $mod.s){',
- ' $mod.e = +$l;',
- ' $mod.e2 = $mod.e;',
- '};',
- 'for ($mod.er = 1; $mod.er <= 2; $mod.er++) ;',
- '']));
- end;
- procedure TTestModule.TestNestBegin;
- begin
- StartProgram(false);
- Add('begin');
- Add(' begin');
- Add(' begin');
- Add(' end;');
- Add(' begin');
- Add(' if true then ;');
- Add(' end;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestNestBegin',
- '',
- 'if (true) ;');
- end;
- procedure TTestModule.TestUnitImplVars;
- begin
- StartUnit(false);
- Add('interface');
- Add('implementation');
- Add('var');
- Add(' V1:longint;');
- Add(' V2:longint = 3;');
- Add(' V3:string = ''abc'';');
- ConvertUnit;
- CheckSource('TestUnitImplVars',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- '']),
- '', // this.$init
- LinesToStr([ // implementation
- '$impl.V1 = 0;',
- '$impl.V2 = 3;',
- '$impl.V3 = "abc";',
- '']) );
- end;
- procedure TTestModule.TestUnitImplConsts;
- begin
- StartUnit(false);
- Add('interface');
- Add('implementation');
- Add('const');
- Add(' v1 = 3;');
- Add(' v2:longint = 4;');
- Add(' v3:string = ''abc'';');
- ConvertUnit;
- CheckSource('TestUnitImplConsts',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- '']),
- '', // this.$init
- LinesToStr([ // implementation
- '$impl.v1 = 3;',
- '$impl.v2 = 4;',
- '$impl.v3 = "abc";',
- '']) );
- end;
- procedure TTestModule.TestUnitImplRecord;
- begin
- StartUnit(false);
- Add('interface');
- Add('implementation');
- Add('type');
- Add(' TMyRecord = record');
- Add(' i: longint;');
- Add(' end;');
- Add('var aRec: TMyRecord;');
- Add('initialization');
- Add(' arec.i:=3;');
- ConvertUnit;
- CheckSource('TestUnitImplRecord',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- '']),
- // this.$init
- '$impl.aRec.i = 3;',
- LinesToStr([ // implementation
- 'rtl.recNewT($impl, "TMyRecord", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- '$impl.aRec = $impl.TMyRecord.$new();',
- '']) );
- end;
- procedure TTestModule.TestRenameJSNameConflict;
- begin
- StartProgram(false);
- Add('var apply: longint;');
- Add('var bind: longint;');
- Add('var call: longint;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRenameJSNameConflict',
- LinesToStr([ // statements
- 'this.Apply = 0;',
- 'this.Bind = 0;',
- 'this.Call = 0;'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestLocalConst;
- begin
- StartProgram(false);
- Add('procedure DoIt;');
- Add('const');
- Add(' cA: longint = 1;');
- Add(' cB = 2;');
- Add(' procedure Sub;');
- Add(' const');
- Add(' csA = 3;');
- Add(' cB: double = 4;');
- Add(' begin');
- Add(' cb:=cb+csa;');
- Add(' ca:=ca+csa+5;');
- Add(' end;');
- Add('begin');
- Add(' ca:=ca+cb+6;');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestLocalConst',
- LinesToStr([
- 'var cA = 1;',
- 'var cB = 2;',
- 'var csA = 3;',
- 'var cB$1 = 4;',
- 'this.DoIt = function () {',
- ' function Sub() {',
- ' cB$1 = cB$1 + 3;',
- ' cA = cA + 3 + 5;',
- ' };',
- ' cA = cA + 2 + 6;',
- '};'
- ]),
- LinesToStr([
- ]));
- end;
- procedure TTestModule.TestVarExternal;
- begin
- StartProgram(false);
- Add('var');
- Add(' NaN: double; external name ''Global.NaN'';');
- Add(' d: double;');
- Add('begin');
- Add(' d:=NaN;');
- ConvertProgram;
- CheckSource('TestVarExternal',
- LinesToStr([
- 'this.d = 0.0;'
- ]),
- LinesToStr([
- '$mod.d = Global.NaN;'
- ]));
- end;
- procedure TTestModule.TestVarExternalOtherUnit;
- begin
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- 'var NaN: double; external name ''Global.NaN'';',
- 'var iV: longint;'
- ]),
- '');
- StartUnit(true);
- Add('interface');
- Add('uses unit2;');
- Add('implementation');
- Add('var');
- Add(' d: double;');
- Add(' i: longint; external name ''$i'';');
- Add('begin');
- Add(' d:=nan;');
- Add(' d:=uNit2.nan;');
- Add(' d:=test1.d;');
- Add(' i:=iv;');
- Add(' i:=uNit2.iv;');
- Add(' i:=test1.i;');
- ConvertUnit;
- CheckSource('TestVarExternalOtherUnit',
- LinesToStr([
- 'var $impl = $mod.$impl;',
- '']),
- LinesToStr([ // this.$init
- '$impl.d = Global.NaN;',
- '$impl.d = Global.NaN;',
- '$impl.d = $impl.d;',
- '$i = pas.unit2.iV;',
- '$i = pas.unit2.iV;',
- '$i = $i;',
- '']),
- LinesToStr([ // implementation
- '$impl.d = 0.0;',
- '']) );
- end;
- procedure TTestModule.TestVarAbsoluteFail;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' a: longint;',
- ' b: longword absolute a;',
- 'begin']);
- SetExpectedPasResolverError('Invalid variable modifier "absolute"',nInvalidVariableModifier);
- ConvertProgram;
- end;
- procedure TTestModule.TestConstExternal;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' PI: double; external name ''Global.PI'';',
- ' Tau = 2*pi;',
- 'var d: double;',
- 'begin',
- ' d:=pi;',
- ' d:=tau+pi;']);
- ConvertProgram;
- CheckSource('TestConstExternal',
- LinesToStr([
- 'this.Tau = 2*Global.PI;',
- 'this.d = 0.0;'
- ]),
- LinesToStr([
- '$mod.d = Global.PI;',
- '$mod.d = $mod.Tau + Global.PI;'
- ]));
- end;
- procedure TTestModule.TestDouble;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TDateTime = double;',
- 'const',
- ' a = TDateTime(2.7);',
- ' b = a + TDateTime(1.7);',
- ' c = 0.9 + 0.1;',
- ' f0_1 = 0.1;',
- ' f0_3 = 0.3;',
- ' fn0_1 = -0.1;',
- ' fn0_3 = -0.3;',
- ' fn0_003 = -0.003;',
- ' fn0_123456789 = -0.123456789;',
- ' fn300_0 = -300.0;',
- ' fn123456_0 = -123456.0;',
- ' fn1234567_8 = -1234567.8;',
- ' fn12345678_9 = -12345678.9;',
- ' f1_0En12 = 1E-12;',
- ' fn1_0En12 = -1E-12;',
- ' maxdouble = 1.7e+308;',
- ' mindouble = -1.7e+308;',
- ' MinSafeIntDouble = -$1fffffffffffff;',
- ' MinSafeIntDouble2 = -$20000000000000-1;',
- ' MaxSafeIntDouble = $1fffffffffffff;',
- ' DZeroResolution = 1E-12;',
- ' Minus1 = -1E-12;',
- ' EPS = 1E-9;',
- ' DELTA = 0.001;',
- ' Big = 129.789E+100;',
- ' Test0_15 = 0.15;',
- ' Test999 = 2.9999999999999;',
- ' Test111999 = 211199999999999000.0;',
- ' TestMinus111999 = -211199999999999000.0;',
- 'var',
- ' d: double = b;',
- 'begin',
- ' d:=1.0;',
- ' d:=1.0/3.0;',
- ' d:=1/3;',
- ' d:=5.0E-324;',
- ' d:=1.7E308;',
- ' d:=001.00E00;',
- ' d:=002.00E001;',
- ' d:=003.000E000;',
- ' d:=-004.00E-00;',
- ' d:=-005.00E-001;',
- ' d:=10**3;',
- ' d:=10 mod 3;',
- ' d:=10 div 3;',
- ' d:=c;',
- ' d:=f0_1;',
- ' d:=f0_3;',
- ' d:=fn0_1;',
- ' d:=fn0_3;',
- ' d:=fn0_003;',
- ' d:=fn0_123456789;',
- ' d:=fn300_0;',
- ' d:=fn123456_0;',
- ' d:=fn1234567_8;',
- ' d:=fn12345678_9;',
- ' d:=f1_0En12;',
- ' d:=fn1_0En12;',
- ' d:=maxdouble;',
- ' d:=mindouble;',
- ' d:=MinSafeIntDouble;',
- ' d:=double(MinSafeIntDouble);',
- ' d:=MinSafeIntDouble2;',
- ' d:=double(MinSafeIntDouble2);',
- ' d:=MaxSafeIntDouble;',
- ' d:=default(double);',
- '']);
- ConvertProgram;
- CheckSource('TestDouble',
- LinesToStr([
- 'this.a = 2.7;',
- 'this.b = 2.7 + 1.7;',
- 'this.c = 0.9 + 0.1;',
- 'this.f0_1 = 0.1;',
- 'this.f0_3 = 0.3;',
- 'this.fn0_1 = -0.1;',
- 'this.fn0_3 = -0.3;',
- 'this.fn0_003 = -0.003;',
- 'this.fn0_123456789 = -0.123456789;',
- 'this.fn300_0 = -300.0;',
- 'this.fn123456_0 = -123456.0;',
- 'this.fn1234567_8 = -1234567.8;',
- 'this.fn12345678_9 = -12345678.9;',
- 'this.f1_0En12 = 1E-12;',
- 'this.fn1_0En12 = -1E-12;',
- 'this.maxdouble = 1.7e+308;',
- 'this.mindouble = -1.7e+308;',
- 'this.MinSafeIntDouble = -0x1fffffffffffff;',
- 'this.MinSafeIntDouble2 = -0x20000000000000 - 1;',
- 'this.MaxSafeIntDouble = 0x1fffffffffffff;',
- 'this.DZeroResolution = 1E-12;',
- 'this.Minus1 = -1E-12;',
- 'this.EPS = 1E-9;',
- 'this.DELTA = 0.001;',
- 'this.Big = 129.789E+100;',
- 'this.Test0_15 = 0.15;',
- 'this.Test999 = 2.9999999999999;',
- 'this.Test111999 = 211199999999999000.0;',
- 'this.TestMinus111999 = -211199999999999000.0;',
- 'this.d = 4.4;'
- ]),
- LinesToStr([
- '$mod.d = 1.0;',
- '$mod.d = 1.0 / 3.0;',
- '$mod.d = 1 / 3;',
- '$mod.d = 5.0E-324;',
- '$mod.d = 1.7E308;',
- '$mod.d = 1.00E0;',
- '$mod.d = 2.00E1;',
- '$mod.d = 3.000E0;',
- '$mod.d = -4.00E-0;',
- '$mod.d = -5.00E-1;',
- '$mod.d = Math.pow(10, 3);',
- '$mod.d = 10 % 3;',
- '$mod.d = rtl.trunc(10 / 3);',
- '$mod.d = 1;',
- '$mod.d = 0.1;',
- '$mod.d = 0.3;',
- '$mod.d = -0.1;',
- '$mod.d = -0.3;',
- '$mod.d = -0.003;',
- '$mod.d = -0.123456789;',
- '$mod.d = -300;',
- '$mod.d = -123456;',
- '$mod.d = -1234567.8;',
- '$mod.d = -1.23456789E7;',
- '$mod.d = 1E-12;',
- '$mod.d = -1E-12;',
- '$mod.d = 1.7E308;',
- '$mod.d = -1.7E308;',
- '$mod.d = -9007199254740991;',
- '$mod.d = -9007199254740991;',
- '$mod.d = -9.007199254740992E15;',
- '$mod.d = -9.007199254740992E15;',
- '$mod.d = 9007199254740991;',
- '$mod.d = 0.0;',
- '']));
- end;
- procedure TTestModule.TestInteger;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' MinInt = low(NativeInt);',
- ' MaxInt = high(NativeInt);',
- 'type',
- ' {#TMyInt}TMyInt = MinInt..MaxInt;',
- 'const',
- ' a = low(TMyInt)+High(TMyInt);',
- 'var',
- ' i: TMyInt;',
- 'begin',
- ' i:=-MinInt;',
- ' i:=default(TMyInt);',
- ' i:=low(i)+high(i);',
- '']);
- ConvertProgram;
- CheckSource('TestIntegerRange',
- LinesToStr([
- 'this.MinInt = -9007199254740991;',
- 'this.MaxInt = 9007199254740991;',
- 'this.a = -9007199254740991 + 9007199254740991;',
- 'this.i = 0;',
- '']),
- LinesToStr([
- '$mod.i = - -9007199254740991;',
- '$mod.i = -9007199254740991;',
- '$mod.i = -9007199254740991 + 9007199254740991;',
- '']));
- end;
- procedure TTestModule.TestIntegerRange;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' MinInt = -1;',
- ' MaxInt = +1;',
- 'type',
- ' {#TMyInt}TMyInt = MinInt..MaxInt;',
- ' TInt2 = 1..3;',
- 'const',
- ' a = low(TMyInt)+High(TMyInt);',
- ' b = low(TInt2)+High(TInt2);',
- ' s1 = [1];',
- ' s2 = [1,2];',
- ' s3 = [1..3];',
- ' s4 = [low(shortint)..high(shortint)];',
- ' s5 = [succ(low(shortint))..pred(high(shortint))];',
- ' s6 = 1 in s2;',
- 'var',
- ' i: TMyInt;',
- ' i2: TInt2;',
- 'begin',
- ' i:=i2;',
- ' i:=default(TMyInt);',
- ' if i=i2 then ;',
- ' i:=ord(i2);',
- '']);
- ConvertProgram;
- CheckSource('TestIntegerRange',
- LinesToStr([
- 'this.MinInt = -1;',
- 'this.MaxInt = +1;',
- 'this.a = -1 + 1;',
- 'this.b = 1 + 3;',
- 'this.s1 = rtl.createSet(1);',
- 'this.s2 = rtl.createSet(1, 2);',
- 'this.s3 = rtl.createSet(null, 1, 3);',
- 'this.s4 = rtl.createSet(null, -128, 127);',
- 'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
- 'this.s6 = 1 in this.s2;',
- 'this.i = 0;',
- 'this.i2 = 0;',
- '']),
- LinesToStr([
- '$mod.i = $mod.i2;',
- '$mod.i = -1;',
- 'if ($mod.i === $mod.i2) ;',
- '$mod.i = $mod.i2;',
- '']));
- end;
- procedure TTestModule.TestIntegerTypecasts;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' i: nativeint;',
- ' b: byte;',
- ' sh: shortint;',
- ' w: word;',
- ' sm: smallint;',
- ' lw: longword;',
- ' li: longint;',
- 'begin',
- ' b:=byte(i);',
- ' sh:=shortint(i);',
- ' w:=word(i);',
- ' sm:=smallint(i);',
- ' lw:=longword(i);',
- ' li:=longint(i);',
- '']);
- ConvertProgram;
- CheckSource('TestIntegerTypecasts',
- LinesToStr([
- 'this.i = 0;',
- 'this.b = 0;',
- 'this.sh = 0;',
- 'this.w = 0;',
- 'this.sm = 0;',
- 'this.lw = 0;',
- 'this.li = 0;',
- '']),
- LinesToStr([
- '$mod.b = $mod.i & 255;',
- '$mod.sh = (($mod.i & 255) << 24) >> 24;',
- '$mod.w = $mod.i & 65535;',
- '$mod.sm = (($mod.i & 65535) << 16) >> 16;',
- '$mod.lw = $mod.i >>> 0;',
- '$mod.li = $mod.i & 0xFFFFFFFF;',
- '']));
- end;
- procedure TTestModule.TestInteger_BitwiseShrNativeInt;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' i,j: nativeint;',
- 'begin',
- ' i:=i shr 0;',
- ' i:=i shr 1;',
- ' i:=i shr 3;',
- ' i:=i shr 54;',
- ' i:=j shr i;',
- '']);
- ConvertProgram;
- CheckResolverUnexpectedHints;
- CheckSource('TestInteger_BitwiseShrNativeInt',
- LinesToStr([
- 'this.i = 0;',
- 'this.j = 0;',
- '']),
- LinesToStr([
- '$mod.i = $mod.i;',
- '$mod.i = Math.floor($mod.i / 2);',
- '$mod.i = Math.floor($mod.i / 8);',
- '$mod.i = 0;',
- '$mod.i = rtl.shr($mod.j, $mod.i);',
- '']));
- end;
- procedure TTestModule.TestInteger_BitwiseShlNativeInt;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' i: nativeint;',
- 'begin',
- ' i:=i shl 0;',
- ' i:=i shl 54;',
- ' i:=123456789012 shl 1;',
- ' i:=i shl 1;',
- '']);
- ConvertProgram;
- CheckResolverUnexpectedHints;
- CheckSource('TestInteger_BitwiseShrNativeInt',
- LinesToStr([
- 'this.i = 0;',
- '']),
- LinesToStr([
- '$mod.i = $mod.i;',
- '$mod.i = 0;',
- '$mod.i = 246913578024;',
- '$mod.i = rtl.shl($mod.i, 1);',
- '']));
- end;
- procedure TTestModule.TestInteger_SystemFunc;
- begin
- StartProgram(true);
- Add([
- 'var',
- ' i: byte;',
- ' s: string;',
- 'begin',
- ' system.inc(i);',
- ' system.str(i,s);',
- ' s:=system.str(i);',
- ' i:=system.low(i);',
- ' i:=system.high(i);',
- ' i:=system.pred(i);',
- ' i:=system.succ(i);',
- ' i:=system.ord(i);',
- '']);
- ConvertProgram;
- CheckResolverUnexpectedHints;
- CheckSource('TestInteger_SystemFunc',
- LinesToStr([
- 'this.i = 0;',
- 'this.s = "";',
- '']),
- LinesToStr([
- '$mod.i += 1;',
- '$mod.s = "" + $mod.i;',
- '$mod.s = "" + $mod.i;',
- '$mod.i = 0;',
- '$mod.i = 255;',
- '$mod.i = $mod.i - 1;',
- '$mod.i = $mod.i + 1;',
- '$mod.i = $mod.i;',
- '']));
- end;
- procedure TTestModule.TestCurrency;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TCoin = currency;',
- 'const',
- ' a = TCoin(2.7);',
- ' b = a + TCoin(1.7);',
- ' MinSafeIntCurrency: TCoin = -92233720368.5477;',
- ' MaxSafeIntCurrency: TCoin = 92233720368.5477;',
- 'var',
- ' c: TCoin = b;',
- ' i: nativeint;',
- ' d: double;',
- ' j: jsvalue;',
- 'function DoIt(c: currency): currency; begin end;',
- 'function GetIt(d: double): double; begin end;',
- 'procedure Write(v: jsvalue); begin end;',
- 'begin',
- ' c:=1.0;',
- ' c:=0.1;',
- ' c:=1.0/3.0;',
- ' c:=1/3;',
- ' c:=a;',
- ' d:=c;',
- ' c:=d;',
- ' c:=currency(c);',
- ' c:=currency(d);',
- ' d:=double(c);',
- ' c:=i;',
- ' c:=currency(i);',
- //' i:=c;', not allowed
- ' i:=nativeint(c);',
- ' c:=c+a;',
- ' c:=-c-a;',
- ' c:=d+c;',
- ' c:=c+d;',
- ' c:=d-c;',
- ' c:=c-d;',
- ' c:=c*a;',
- ' c:=a*c;',
- ' c:=d*c;',
- ' c:=c*d;',
- ' c:=c/a;',
- ' c:=a/c;',
- ' c:=d/c;',
- ' c:=c/d;',
- ' c:=c**a;',
- ' c:=a**c;',
- ' c:=d**c;',
- ' c:=c**d;',
- ' if c=c then ;',
- ' if c=a then ;',
- ' if a=c then ;',
- ' if d=c then ;',
- ' if c=d then ;',
- ' c:=DoIt(c);',
- ' c:=DoIt(i);',
- ' c:=DoIt(d);',
- ' c:=GetIt(c);',
- ' j:=c;',
- ' Write(c);',
- ' c:=default(currency);',
- ' j:=str(c);',
- ' j:=str(c:0:3);',
- '']);
- ConvertProgram;
- CheckSource('TestCurrency',
- LinesToStr([
- 'this.a = 27000;',
- 'this.b = this.a + 17000;',
- 'this.MinSafeIntCurrency = -92233720368.5477;',
- 'this.MaxSafeIntCurrency = 92233720368.5477;',
- 'this.c = this.b;',
- 'this.i = 0;',
- 'this.d = 0.0;',
- 'this.j = undefined;',
- 'this.DoIt = function (c) {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.GetIt = function (d) {',
- ' var Result = 0.0;',
- ' return Result;',
- '};',
- 'this.Write = function (v) {',
- '};',
- '']),
- LinesToStr([
- '$mod.c = 10000;',
- '$mod.c = 1000;',
- '$mod.c = rtl.trunc((1.0 / 3.0) * 10000);',
- '$mod.c = rtl.trunc((1 / 3) * 10000);',
- '$mod.c = $mod.a;',
- '$mod.d = $mod.c / 10000;',
- '$mod.c = rtl.trunc($mod.d * 10000);',
- '$mod.c = $mod.c;',
- '$mod.c = $mod.d * 10000;',
- '$mod.d = $mod.c / 10000;',
- '$mod.c = $mod.i * 10000;',
- '$mod.c = $mod.i * 10000;',
- '$mod.i = rtl.trunc($mod.c / 10000);',
- '$mod.c = $mod.c + $mod.a;',
- '$mod.c = -$mod.c - $mod.a;',
- '$mod.c = ($mod.d * 10000) + $mod.c;',
- '$mod.c = $mod.c + ($mod.d * 10000);',
- '$mod.c = ($mod.d * 10000) - $mod.c;',
- '$mod.c = $mod.c - ($mod.d * 10000);',
- '$mod.c = ($mod.c * $mod.a) / 10000;',
- '$mod.c = ($mod.a * $mod.c) / 10000;',
- '$mod.c = $mod.d * $mod.c;',
- '$mod.c = $mod.c * $mod.d;',
- '$mod.c = rtl.trunc(($mod.c / $mod.a) * 10000);',
- '$mod.c = rtl.trunc(($mod.a / $mod.c) * 10000);',
- '$mod.c = rtl.trunc($mod.d / $mod.c);',
- '$mod.c = rtl.trunc($mod.c / $mod.d);',
- '$mod.c = rtl.trunc(Math.pow($mod.c / 10000, $mod.a / 10000) * 10000);',
- '$mod.c = rtl.trunc(Math.pow($mod.a / 10000, $mod.c / 10000) * 10000);',
- '$mod.c = rtl.trunc(Math.pow($mod.d, $mod.c / 10000) * 10000);',
- '$mod.c = rtl.trunc(Math.pow($mod.c / 10000, $mod.d) * 10000);',
- 'if ($mod.c === $mod.c) ;',
- 'if ($mod.c === $mod.a) ;',
- 'if ($mod.a === $mod.c) ;',
- 'if (($mod.d * 10000) === $mod.c) ;',
- 'if ($mod.c === ($mod.d * 10000)) ;',
- '$mod.c = $mod.DoIt($mod.c);',
- '$mod.c = $mod.DoIt($mod.i * 10000);',
- '$mod.c = $mod.DoIt($mod.d * 10000);',
- '$mod.c = rtl.trunc($mod.GetIt($mod.c / 10000) * 10000);',
- '$mod.j = $mod.c / 10000;',
- '$mod.Write($mod.c / 10000);',
- '$mod.c = 0;',
- '$mod.j = rtl.floatToStr($mod.c / 10000);',
- '$mod.j = rtl.floatToStr($mod.c / 10000, 0, 3);',
- '']));
- end;
- procedure TTestModule.TestForBoolDo;
- begin
- StartProgram(false);
- Add([
- 'var b: boolean;',
- 'begin',
- ' for b:=false to true do ;',
- ' for b:=b downto false do ;',
- ' for b in boolean do ;',
- '']);
- ConvertProgram;
- CheckSource('TestForBoolDo',
- LinesToStr([ // statements
- 'this.b = false;']),
- LinesToStr([ // this.$main
- 'for (var $l = 0; $l <= 1; $l++) $mod.b = $l !== 0;',
- 'for (var $l1 = +$mod.b; $l1 >= 0; $l1--) $mod.b = $l1 !== 0;',
- 'for (var $l2 = 0; $l2 <= 1; $l2++) $mod.b = $l2 !== 0;',
- '']));
- end;
- procedure TTestModule.TestForIntDo;
- begin
- StartProgram(false);
- Add([
- 'var i: longint;',
- 'begin',
- ' for i:=3 to 5 do ;',
- ' for i:=i downto 2 do ;',
- ' for i in byte do ;',
- '']);
- ConvertProgram;
- CheckSource('TestForIntDo',
- LinesToStr([ // statements
- 'this.i = 0;']),
- LinesToStr([ // this.$main
- 'for ($mod.i = 3; $mod.i <= 5; $mod.i++) ;',
- 'for (var $l = $mod.i; $l >= 2; $l--) $mod.i = $l;',
- 'for (var $l1 = 0; $l1 <= 255; $l1++) $mod.i = $l1;',
- '']));
- end;
- procedure TTestModule.TestForIntInDo;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TSetOfInt = set of byte;',
- ' TIntRg = 3..7;',
- ' TSetOfIntRg = set of TIntRg;',
- 'var',
- ' i,i2: longint;',
- ' a1: array of byte;',
- ' a2: array[1..3] of byte;',
- ' soi: TSetOfInt;',
- ' soir: TSetOfIntRg;',
- ' ir: TIntRg;',
- 'begin',
- ' for i in byte do ;',
- ' for i in a1 do ;',
- ' for i in a2 do ;',
- ' for i in [11..13] do ;',
- ' for i in TSetOfInt do ;',
- ' for i in TIntRg do ;',
- ' for i in soi do i2:=i;',
- ' for i in TSetOfIntRg do ;',
- ' for i in soir do ;',
- ' for ir in TIntRg do ;',
- ' for ir in TSetOfIntRg do ;',
- ' for ir in soir do ;',
- '']);
- ConvertProgram;
- CheckSource('TestForIntInDo',
- LinesToStr([ // statements
- 'this.i = 0;',
- 'this.i2 = 0;',
- 'this.a1 = [];',
- 'this.a2 = rtl.arraySetLength(null, 0, 3);',
- 'this.soi = {};',
- 'this.soir = {};',
- 'this.ir = 0;',
- '']),
- LinesToStr([ // this.$main
- 'for (var $l = 0; $l <= 255; $l++) $mod.i = $l;',
- 'for (var $in = $mod.a1, $l1 = 0, $end = rtl.length($in) - 1; $l1 <= $end; $l1++) $mod.i = $in[$l1];',
- 'for (var $in1 = $mod.a2, $l2 = 0, $end1 = rtl.length($in1) - 1; $l2 <= $end1; $l2++) $mod.i = $in1[$l2];',
- 'for (var $l3 = 11; $l3 <= 13; $l3++) $mod.i = $l3;',
- 'for (var $l4 = 0; $l4 <= 255; $l4++) $mod.i = $l4;',
- 'for (var $l5 = 3; $l5 <= 7; $l5++) $mod.i = $l5;',
- 'for (var $l6 in $mod.soi) {',
- ' $mod.i = +$l6;',
- ' $mod.i2 = $mod.i;',
- '};',
- 'for (var $l7 = 3; $l7 <= 7; $l7++) $mod.i = $l7;',
- 'for (var $l8 in $mod.soir) $mod.i = +$l8;',
- 'for (var $l9 = 3; $l9 <= 7; $l9++) $mod.ir = $l9;',
- 'for (var $l10 = 3; $l10 <= 7; $l10++) $mod.ir = $l10;',
- 'for (var $l11 in $mod.soir) $mod.ir = +$l11;',
- '']));
- end;
- procedure TTestModule.TestCharConst;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' a = #$00F3;',
- ' c: char = ''1'';',
- ' wc: widechar = ''ä'';',
- 'begin',
- ' c:=#0;',
- ' c:=#1;',
- ' c:=#9;',
- ' c:=#10;',
- ' c:=#13;',
- ' c:=#31;',
- ' c:=#32;',
- ' c:=#$A;',
- ' c:=#$0A;',
- ' c:=#$b;',
- ' c:=#$0b;',
- ' c:=^A;',
- ' c:=''"'';',
- ' c:=default(char);',
- ' c:=#$00E4;', // ä
- ' c:=''ä'';',
- ' c:=#$E4;', // ä
- ' c:=#$D800;', // invalid UTF-16
- ' c:=#$DFFF;', // invalid UTF-16
- ' c:=#$FFFF;', // last UCS-2
- ' c:=high(c);', // last UCS-2
- ' c:=#269;',
- '']);
- ConvertProgram;
- CheckSource('TestCharConst',
- LinesToStr([
- 'this.a="ó";',
- 'this.c="1";',
- 'this.wc="ä";'
- ]),
- LinesToStr([
- '$mod.c="\x00";',
- '$mod.c="\x01";',
- '$mod.c="\t";',
- '$mod.c="\n";',
- '$mod.c="\r";',
- '$mod.c="\x1F";',
- '$mod.c=" ";',
- '$mod.c="\n";',
- '$mod.c="\n";',
- '$mod.c="\x0B";',
- '$mod.c="\x0B";',
- '$mod.c="\x01";',
- '$mod.c=''"'';',
- '$mod.c="\x00";',
- '$mod.c = "ä";',
- '$mod.c = "ä";',
- '$mod.c = "ä";',
- '$mod.c="\uD800";',
- '$mod.c="\uDFFF";',
- '$mod.c="\uFFFF";',
- '$mod.c="\uFFFF";',
- '$mod.c = "č";',
- '']));
- end;
- procedure TTestModule.TestChar_Compare;
- begin
- StartProgram(false);
- Add('var');
- Add(' c: char;');
- Add(' b: boolean;');
- Add('begin');
- Add(' b:=c=''1'';');
- Add(' b:=''2''=c;');
- Add(' b:=''3''=''4'';');
- Add(' b:=c<>''5'';');
- Add(' b:=''6''<>c;');
- Add(' b:=c>''7'';');
- Add(' b:=''8''>c;');
- Add(' b:=c>=''9'';');
- Add(' b:=''A''>=c;');
- Add(' b:=c<''B'';');
- Add(' b:=''C''<c;');
- Add(' b:=c<=''D'';');
- Add(' b:=''E''<=c;');
- ConvertProgram;
- CheckSource('TestChar_Compare',
- LinesToStr([
- 'this.c="";',
- 'this.b = false;'
- ]),
- LinesToStr([
- '$mod.b = $mod.c === "1";',
- '$mod.b = "2" === $mod.c;',
- '$mod.b = "3" === "4";',
- '$mod.b = $mod.c !== "5";',
- '$mod.b = "6" !== $mod.c;',
- '$mod.b = $mod.c > "7";',
- '$mod.b = "8" > $mod.c;',
- '$mod.b = $mod.c >= "9";',
- '$mod.b = "A" >= $mod.c;',
- '$mod.b = $mod.c < "B";',
- '$mod.b = "C" < $mod.c;',
- '$mod.b = $mod.c <= "D";',
- '$mod.b = "E" <= $mod.c;',
- '']));
- end;
- procedure TTestModule.TestChar_BuiltInProcs;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' c: char;',
- ' i: longint;',
- ' s: string;',
- 'begin',
- ' i:=ord(c);',
- ' i:=ord(s[i]);',
- ' c:=chr(i);',
- ' c:=pred(c);',
- ' c:=succ(c);',
- ' c:=low(c);',
- ' c:=high(c);',
- ' i:=byte(c);',
- ' i:=word(c);',
- ' i:=longint(c);',
- '']);
- ConvertProgram;
- CheckSource('TestChar_BuiltInProcs',
- LinesToStr([
- 'this.c = "";',
- 'this.i = 0;',
- 'this.s = "";'
- ]),
- LinesToStr([
- '$mod.i = $mod.c.charCodeAt();',
- '$mod.i = $mod.s.charCodeAt($mod.i-1);',
- '$mod.c = String.fromCharCode($mod.i);',
- '$mod.c = String.fromCharCode($mod.c.charCodeAt() - 1);',
- '$mod.c = String.fromCharCode($mod.c.charCodeAt() + 1);',
- '$mod.c = "\x00";',
- '$mod.c = "\uFFFF";',
- '$mod.i = $mod.c.charCodeAt() & 255;',
- '$mod.i = $mod.c.charCodeAt();',
- '$mod.i = $mod.c.charCodeAt() & 0xFFFFFFFF;',
- '']));
- end;
- procedure TTestModule.TestStringConst;
- begin
- StartProgram(false);
- Add([
- '{$H+}',
- 'const',
- ' a = #$00F3#$017C;', // first <256, then >=256
- ' b = string(''a'');',
- ' c = string(''ä'');',
- ' d = UnicodeString(''b'');',
- ' e = UnicodeString(''ö'');',
- 'var',
- ' s: string = ''abc'';',
- 'begin',
- ' s:='''';',
- ' s:=#13#10;',
- ' s:=#9''foo'';',
- ' s:=#$A9;',
- ' s:=''foo''#13''bar'';',
- ' s:=''"'';',
- ' s:=''"''''"'';',
- ' s:=#$20AC;', // euro
- ' s:=#$10437;', // outside BMP
- ' s:=''abc''#$20AC;', // ascii,#
- ' s:=''ä''#$20AC;', // non ascii,#
- ' s:=#$20AC''abc'';', // #, ascii
- ' s:=#$20AC''ä'';', // #, non ascii
- ' s:=default(string);',
- ' s:=concat(s);',
- ' s:=concat(s,''a'',s);',
- ' s:=#250#269;',
- //' s:=#$2F804;',
- // ToDo: \uD87E\uDC04 -> \u{2F804}
- '']);
- ConvertProgram;
- CheckSource('TestStringConst',
- LinesToStr([
- 'this.a = "óż";',
- 'this.b = "a";',
- 'this.c = "ä";',
- 'this.d = "b";',
- 'this.e = "ö";',
- 'this.s="abc";',
- '']),
- LinesToStr([
- '$mod.s="";',
- '$mod.s="\r\n";',
- '$mod.s="\tfoo";',
- '$mod.s="©";',
- '$mod.s="foo\rbar";',
- '$mod.s=''"'';',
- '$mod.s=''"\''"'';',
- '$mod.s="€";',
- '$mod.s="'#$F0#$90#$90#$B7'";',
- '$mod.s = "abc€";',
- '$mod.s = "ä€";',
- '$mod.s = "€abc";',
- '$mod.s = "ۊ";',
- '$mod.s="";',
- '$mod.s = $mod.s;',
- '$mod.s = $mod.s.concat("a", $mod.s);',
- '$mod.s = "úč";',
- '']));
- end;
- procedure TTestModule.TestStringConst_InvalidUTF16;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' a: char = #$D87E;',
- ' b: string = #$D87E;',
- ' c: string = #$D87E#43;',
- 'begin',
- ' c:=''abc''#$D87E;',
- ' c:=#0#1#2;',
- ' c:=#127;',
- ' c:=#128;',
- ' c:=#255;',
- ' c:=#256;',
- '']);
- ConvertProgram;
- CheckSource('TestStringConst',
- LinesToStr([
- 'this.a = "\uD87E";',
- 'this.b = "\uD87E";',
- 'this.c = "\uD87E+";',
- '']),
- LinesToStr([
- '$mod.c = "abc\uD87E";',
- '$mod.c = "\x00\x01\x02";',
- '$mod.c = "'#127'";',
- '$mod.c = "'#$c2#$80'";',
- '$mod.c = "'#$c3#$BF'";',
- '$mod.c = "'#$c4#$80'";',
- '']));
- end;
- procedure TTestModule.TestStringConstSurrogate;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' s: string;',
- 'begin',
- ' s:=''😊'';', // 1F60A
- '']);
- ConvertProgram;
- CheckSource('TestStringConstSurrogate',
- LinesToStr([
- 'this.s="";'
- ]),
- LinesToStr([
- '$mod.s="😊";'
- ]));
- end;
- procedure TTestModule.TestString_Length;
- begin
- StartProgram(false);
- Add('const c = ''foo'';');
- Add('var');
- Add(' s: string;');
- Add(' i: longint;');
- Add('begin');
- Add(' i:=length(s);');
- Add(' i:=length(s+s);');
- Add(' i:=length(''abc'');');
- Add(' i:=length(c);');
- ConvertProgram;
- CheckSource('TestString_Length',
- LinesToStr([
- 'this.c = "foo";',
- 'this.s = "";',
- 'this.i = 0;',
- '']),
- LinesToStr([
- '$mod.i = $mod.s.length;',
- '$mod.i = ($mod.s+$mod.s).length;',
- '$mod.i = "abc".length;',
- '$mod.i = $mod.c.length;',
- '']));
- end;
- procedure TTestModule.TestString_Compare;
- begin
- StartProgram(false);
- Add('var');
- Add(' s, t: string;');
- Add(' b: boolean;');
- Add('begin');
- Add(' b:=s=t;');
- Add(' b:=s<>t;');
- Add(' b:=s>t;');
- Add(' b:=s>=t;');
- Add(' b:=s<t;');
- Add(' b:=s<=t;');
- ConvertProgram;
- CheckSource('TestString_Compare',
- LinesToStr([ // statements
- 'this.s = "";',
- 'this.t = "";',
- 'this.b =false;'
- ]),
- LinesToStr([ // this.$main
- '$mod.b = $mod.s === $mod.t;',
- '$mod.b = $mod.s !== $mod.t;',
- '$mod.b = $mod.s > $mod.t;',
- '$mod.b = $mod.s >= $mod.t;',
- '$mod.b = $mod.s < $mod.t;',
- '$mod.b = $mod.s <= $mod.t;',
- '']));
- end;
- procedure TTestModule.TestString_SetLength;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt(var s: string);',
- 'begin',
- ' SetLength(s,2);',
- 'end;',
- 'var s: string;',
- 'begin',
- ' SetLength(s,3);',
- '']);
- ConvertProgram;
- CheckSource('TestString_SetLength',
- LinesToStr([ // statements
- 'this.DoIt = function (s) {',
- ' s.set(rtl.strSetLength(s.get(), 2));',
- '};',
- 'this.s = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.s = rtl.strSetLength($mod.s, 3);'
- ]));
- end;
- procedure TTestModule.TestString_CharAt;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' s: string;',
- ' c: char;',
- ' b: boolean;',
- 'begin',
- ' b:= s[1] = c;',
- ' b:= c = s[1];',
- ' b:= c <> s[1];',
- ' b:= c > s[1];',
- ' b:= c >= s[1];',
- ' b:= c < s[2];',
- ' b:= c <= s[1];',
- ' s[1] := c;',
- ' s[2+3] := c;']);
- ConvertProgram;
- CheckSource('TestString_CharAt',
- LinesToStr([ // statements
- 'this.s = "";',
- 'this.c = "";',
- 'this.b = false;'
- ]),
- LinesToStr([ // this.$main
- '$mod.b = $mod.s.charAt(0) === $mod.c;',
- '$mod.b = $mod.c === $mod.s.charAt(0);',
- '$mod.b = $mod.c !== $mod.s.charAt(0);',
- '$mod.b = $mod.c > $mod.s.charAt(0);',
- '$mod.b = $mod.c >= $mod.s.charAt(0);',
- '$mod.b = $mod.c < $mod.s.charAt(1);',
- '$mod.b = $mod.c <= $mod.s.charAt(0);',
- '$mod.s = rtl.setCharAt($mod.s, 0, $mod.c);',
- '$mod.s = rtl.setCharAt($mod.s, (2 + 3) - 1, $mod.c);',
- '']));
- end;
- procedure TTestModule.TestStringHMinusFail;
- begin
- StartProgram(false);
- Add([
- '{$H-}',
- 'var s: string;',
- 'begin']);
- ConvertProgram;
- CheckHint(mtWarning,nWarnIllegalCompilerDirectiveX,'Warning: test1.pp(3,6) : Illegal compiler directive "H-"');
- end;
- procedure TTestModule.TestStr;
- begin
- StartProgram(false);
- Add('var');
- Add(' b: boolean;');
- Add(' i: longint;');
- Add(' d: double;');
- Add(' s: string;');
- Add('begin');
- Add(' str(b,s);');
- Add(' str(i,s);');
- Add(' str(d,s);');
- Add(' str(i:3,s);');
- Add(' str(d:3:2,s);');
- Add(' Str(12.456:12:1,s);');
- Add(' Str(12.456:12,s);');
- Add(' s:=str(b);');
- Add(' s:=str(i);');
- Add(' s:=str(d);');
- Add(' s:=str(i,i);');
- Add(' s:=str(i:3);');
- Add(' s:=str(d:3:2);');
- Add(' s:=str(i:4,i);');
- Add(' s:=str(i,i:5);');
- Add(' s:=str(i:4,i:5);');
- Add(' s:=str(s,s);');
- Add(' s:=str(s,''foo'');');
- ConvertProgram;
- CheckSource('TestStr',
- LinesToStr([ // statements
- 'this.b = false;',
- 'this.i = 0;',
- 'this.d = 0.0;',
- 'this.s = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.s = ""+$mod.b;',
- '$mod.s = ""+$mod.i;',
- '$mod.s = rtl.floatToStr($mod.d);',
- '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
- '$mod.s = rtl.floatToStr($mod.d,3,2);',
- '$mod.s = rtl.floatToStr(12.456,12,1);',
- '$mod.s = rtl.floatToStr(12.456,12);',
- '$mod.s = ""+$mod.b;',
- '$mod.s = ""+$mod.i;',
- '$mod.s = rtl.floatToStr($mod.d);',
- '$mod.s = ""+$mod.i+$mod.i;',
- '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
- '$mod.s = rtl.floatToStr($mod.d,3,2);',
- '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + $mod.i;',
- '$mod.s = "" + $mod.i + rtl.spaceLeft("" + $mod.i, 5);',
- '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + rtl.spaceLeft("" + $mod.i, 5);',
- '$mod.s = $mod.s + $mod.s;',
- '$mod.s = $mod.s + "foo";',
- '']));
- end;
- procedure TTestModule.TestBaseType_AnsiStringFail;
- begin
- StartProgram(false);
- Add('var s: AnsiString');
- SetExpectedPasResolverError('identifier not found "AnsiString"',PasResolveEval.nIdentifierNotFound);
- ConvertProgram;
- end;
- procedure TTestModule.TestBaseType_WideStringFail;
- begin
- StartProgram(false);
- Add('var s: WideString');
- SetExpectedPasResolverError('identifier not found "WideString"',PasResolveEval.nIdentifierNotFound);
- ConvertProgram;
- end;
- procedure TTestModule.TestBaseType_ShortStringFail;
- begin
- StartProgram(false);
- Add('var s: ShortString');
- SetExpectedPasResolverError('identifier not found "ShortString"',PasResolveEval.nIdentifierNotFound);
- ConvertProgram;
- end;
- procedure TTestModule.TestBaseType_RawByteStringFail;
- begin
- StartProgram(false);
- Add('var s: RawByteString');
- SetExpectedPasResolverError('identifier not found "RawByteString"',PasResolveEval.nIdentifierNotFound);
- ConvertProgram;
- end;
- procedure TTestModule.TestTypeShortstring_Fail;
- begin
- StartProgram(false);
- Add('type t = string[12];');
- Add('var s: t;');
- Add('begin');
- SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
- ConvertProgram;
- end;
- procedure TTestModule.TestCharSet_Custom;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TCharRg = ''a''..''z'';',
- ' TSetOfCharRg = set of TCharRg;',
- ' TCharRg2 = ''m''..''p'';',
- 'const',
- ' crg: TCharRg = ''b'';',
- 'var',
- ' c: char;',
- ' crg2: TCharRg2;',
- ' s: TSetOfCharRg;',
- 'begin',
- ' c:=crg;',
- ' crg:=c;',
- ' crg2:=crg;',
- ' if c=crg then ;',
- ' if crg=c then ;',
- ' if crg=crg2 then ;',
- ' if c in s then ;',
- ' if crg2 in s then ;',
- ' c:=default(TCharRg);',
- '']);
- ConvertProgram;
- CheckSource('TestCharSet_Custom',
- LinesToStr([ // statements
- 'this.crg = "b";',
- 'this.c = "";',
- 'this.crg2 = "m";',
- 'this.s = {};',
- '']),
- LinesToStr([ // this.$main
- '$mod.c = $mod.crg;',
- '$mod.crg = $mod.c;',
- '$mod.crg2 = $mod.crg;',
- 'if ($mod.c === $mod.crg) ;',
- 'if ($mod.crg === $mod.c) ;',
- 'if ($mod.crg === $mod.crg2) ;',
- 'if ($mod.c.charCodeAt() in $mod.s) ;',
- 'if ($mod.crg2.charCodeAt() in $mod.s) ;',
- '$mod.c = "a";',
- '']));
- end;
- procedure TTestModule.TestWideChar;
- begin
- StartProgram(false);
- Add([
- 'procedure Fly(var c: char);',
- 'begin',
- 'end;',
- 'procedure Run(var c: widechar);',
- 'begin',
- 'end;',
- 'var',
- ' c: char;',
- ' wc: widechar;',
- ' w: word;',
- 'begin',
- ' Fly(wc);',
- ' Run(c);',
- ' wc:=WideChar(w);',
- ' w:=ord(wc);',
- '']);
- ConvertProgram;
- CheckSource('TestWideChar_VarArg',
- LinesToStr([ // statements
- 'this.Fly = function (c) {',
- '};',
- 'this.Run = function (c) {',
- '};',
- 'this.c = "";',
- 'this.wc = "";',
- 'this.w = 0;',
- '']),
- LinesToStr([ // this.$main
- '$mod.Fly({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.wc;',
- ' },',
- ' set: function (v) {',
- ' this.p.wc = v;',
- ' }',
- '});',
- '$mod.Run({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.c;',
- ' },',
- ' set: function (v) {',
- ' this.p.c = v;',
- ' }',
- '});',
- '$mod.wc = String.fromCharCode($mod.w);',
- '$mod.w = $mod.wc.charCodeAt();',
- '',
- '']));
- end;
- procedure TTestModule.TestForCharDo;
- begin
- StartProgram(false);
- Add([
- 'var c: char;',
- 'begin',
- ' for c:=''a'' to ''c'' do ;',
- ' for c:=c downto ''a'' do ;',
- ' for c:=''Б'' to ''Я'' do ;',
- '']);
- ConvertProgram;
- CheckSource('TestForCharDo',
- LinesToStr([ // statements
- 'this.c = "";']),
- LinesToStr([ // this.$main
- 'for (var $l = 97; $l <= 99; $l++) $mod.c = String.fromCharCode($l);',
- 'for (var $l1 = $mod.c.charCodeAt(); $l1 >= 97; $l1--) $mod.c = String.fromCharCode($l1);',
- 'for (var $l2 = 1041; $l2 <= 1071; $l2++) $mod.c = String.fromCharCode($l2);',
- '']));
- end;
- procedure TTestModule.TestForCharInDo;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TSetOfChar = set of char;',
- ' TCharRg = ''a''..''z'';',
- ' TSetOfCharRg = set of TCharRg;',
- 'const Foo = ''foo'';',
- 'var',
- ' c,c2: char;',
- ' s: string;',
- ' a1: array of char;',
- ' a2: array[1..3] of char;',
- ' soc: TSetOfChar;',
- ' socr: TSetOfCharRg;',
- ' cr: TCharRg;',
- 'begin',
- ' for c in foo do ;',
- ' for c in s do ;',
- ' for c in char do ;',
- ' for c in a1 do ;',
- ' for c in a2 do ;',
- ' for c in [''1''..''3''] do ;',
- ' for c in TSetOfChar do ;',
- ' for c in TCharRg do ;',
- ' for c in soc do c2:=c;',
- ' for c in TSetOfCharRg do ;',
- ' for c in socr do ;',
- ' for cr in TCharRg do ;',
- ' for cr in TSetOfCharRg do ;',
- ' for cr in socr do ;',
- '']);
- ConvertProgram;
- CheckSource('TestForCharInDo',
- LinesToStr([ // statements
- 'this.Foo = "foo";',
- 'this.c = "";',
- 'this.c2 = "";',
- 'this.s = "";',
- 'this.a1 = [];',
- 'this.a2 = rtl.arraySetLength(null, "", 3);',
- 'this.soc = {};',
- 'this.socr = {};',
- 'this.cr = "a";',
- '']),
- LinesToStr([ // this.$main
- 'for (var $in = $mod.Foo, $l = 0, $end = $in.length - 1; $l <= $end; $l++) $mod.c = $in.charAt($l);',
- 'for (var $in1 = $mod.s, $l1 = 0, $end1 = $in1.length - 1; $l1 <= $end1; $l1++) $mod.c = $in1.charAt($l1);',
- 'for (var $l2 = 0; $l2 <= 65535; $l2++) $mod.c = String.fromCharCode($l2);',
- 'for (var $in2 = $mod.a1, $l3 = 0, $end2 = rtl.length($in2) - 1; $l3 <= $end2; $l3++) $mod.c = $in2[$l3];',
- 'for (var $in3 = $mod.a2, $l4 = 0, $end3 = rtl.length($in3) - 1; $l4 <= $end3; $l4++) $mod.c = $in3[$l4];',
- 'for (var $l5 = 49; $l5 <= 51; $l5++) $mod.c = String.fromCharCode($l5);',
- 'for (var $l6 = 0; $l6 <= 65535; $l6++) $mod.c = String.fromCharCode($l6);',
- 'for (var $l7 = 97; $l7 <= 122; $l7++) $mod.c = String.fromCharCode($l7);',
- 'for (var $l8 in $mod.soc) {',
- ' $mod.c = String.fromCharCode($l8);',
- ' $mod.c2 = $mod.c;',
- '};',
- 'for (var $l9 = 97; $l9 <= 122; $l9++) $mod.c = String.fromCharCode($l9);',
- 'for (var $l10 in $mod.socr) $mod.c = String.fromCharCode($l10);',
- 'for (var $l11 = 97; $l11 <= 122; $l11++) $mod.cr = String.fromCharCode($l11);',
- 'for (var $l12 = 97; $l12 <= 122; $l12++) $mod.cr = String.fromCharCode($l12);',
- 'for (var $l13 in $mod.socr) $mod.cr = String.fromCharCode($l13);',
- '']));
- end;
- procedure TTestModule.TestProcTwoArgs;
- begin
- StartProgram(false);
- Add('procedure Test(a,b: longint);');
- Add('begin');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestProcTwoArgs',
- LinesToStr([ // statements
- 'this.Test = function (a,b) {',
- '};'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestProc_DefaultValue;
- begin
- StartProgram(false);
- Add('procedure p1(i: longint = 1);');
- Add('begin');
- Add('end;');
- Add('procedure p2(i: longint = 1; c: char = ''a'');');
- Add('begin');
- Add('end;');
- Add('procedure p3(d: double = 1.0; b: boolean = false; s: string = ''abc'');');
- Add('begin');
- Add('end;');
- Add('begin');
- Add(' p1;');
- Add(' p1();');
- Add(' p1(11);');
- Add(' p2;');
- Add(' p2();');
- Add(' p2(12);');
- Add(' p2(13,''b'');');
- Add(' p3();');
- ConvertProgram;
- CheckSource('TestProc_DefaultValue',
- LinesToStr([ // statements
- 'this.p1 = function (i) {',
- '};',
- 'this.p2 = function (i,c) {',
- '};',
- 'this.p3 = function (d,b,s) {',
- '};'
- ]),
- LinesToStr([ // this.$main
- ' $mod.p1(1);',
- ' $mod.p1(1);',
- ' $mod.p1(11);',
- ' $mod.p2(1,"a");',
- ' $mod.p2(1,"a");',
- ' $mod.p2(12,"a");',
- ' $mod.p2(13,"b");',
- ' $mod.p3(1.0,false,"abc");'
- ]));
- end;
- procedure TTestModule.TestFunctionInt;
- begin
- StartProgram(false);
- Add('function MyTest(Bar: longint): longint;');
- Add('begin');
- Add(' Result:=2*bar');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestFunctionInt',
- LinesToStr([ // statements
- 'this.MyTest = function (Bar) {',
- ' var Result = 0;',
- ' Result = 2*Bar;',
- ' return Result;',
- '};'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestFunctionString;
- begin
- StartProgram(false);
- Add('function Test(Bar: string): string;');
- Add('begin');
- Add(' Result:=bar+BAR');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestFunctionString',
- LinesToStr([ // statements
- 'this.Test = function (Bar) {',
- ' var Result = "";',
- ' Result = Bar+Bar;',
- ' return Result;',
- '};'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestIfThen;
- begin
- StartProgram(false);
- Add([
- 'var b: boolean;',
- 'begin',
- ' if b then ;',
- ' if b then else ;']);
- ConvertProgram;
- CheckSource('TestIfThen',
- LinesToStr([ // statements
- 'this.b = false;',
- '']),
- LinesToStr([ // this.$main
- 'if ($mod.b) ;',
- 'if ($mod.b) ;',
- '']));
- end;
- procedure TTestModule.TestForLoop;
- begin
- StartProgram(false);
- Add('var');
- Add(' vI, vJ, vN: longint;');
- Add('begin');
- Add(' VJ:=0;');
- Add(' VN:=3;');
- Add(' for VI:=1 to VN do');
- Add(' begin');
- Add(' VJ:=VJ+VI;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestForLoop',
- LinesToStr([ // statements
- 'this.vI = 0;',
- 'this.vJ = 0;',
- 'this.vN = 0;'
- ]),
- LinesToStr([ // this.$main
- ' $mod.vJ = 0;',
- ' $mod.vN = 3;',
- ' for (var $l = 1, $end = $mod.vN; $l <= $end; $l++) {',
- ' $mod.vI = $l;',
- ' $mod.vJ = $mod.vJ + $mod.vI;',
- ' };',
- '']));
- end;
- procedure TTestModule.TestForLoopInsideFunction;
- begin
- StartProgram(false);
- Add('function SumNumbers(Count: longint): longint;');
- Add('var');
- Add(' vI, vJ: longint;');
- Add('begin');
- Add(' vj:=0;');
- Add(' for vi:=1 to count do');
- Add(' begin');
- Add(' vj:=vj+vi;');
- Add(' end;');
- Add('end;');
- Add('begin');
- Add(' sumnumbers(3);');
- ConvertProgram;
- CheckSource('TestForLoopInsideFunction',
- LinesToStr([ // statements
- 'this.SumNumbers = function (Count) {',
- ' var Result = 0;',
- ' var vI = 0;',
- ' var vJ = 0;',
- ' vJ = 0;',
- ' for (var $l = 1, $end = Count; $l <= $end; $l++) {',
- ' vI = $l;',
- ' vJ = vJ + vI;',
- ' };',
- ' return Result;',
- '};'
- ]),
- LinesToStr([ // $mod.$main
- ' $mod.SumNumbers(3);'
- ]));
- end;
- procedure TTestModule.TestForLoop_ReadVarAfter;
- begin
- StartProgram(false);
- Add('var');
- Add(' vI: longint;');
- Add('begin');
- Add(' for vi:=1 to 2 do ;');
- Add(' if vi=3 then ;');
- ConvertProgram;
- CheckSource('TestForLoop',
- LinesToStr([ // statements
- 'this.vI = 0;'
- ]),
- LinesToStr([ // this.$main
- ' for ($mod.vI = 1; $mod.vI <= 2; $mod.vI++) ;',
- ' if ($mod.vI===3) ;'
- ]));
- end;
- procedure TTestModule.TestForLoop_Nested;
- begin
- StartProgram(false);
- Add('function SumNumbers(Count: longint): longint;');
- Add('var');
- Add(' vI, vJ, vK: longint;');
- Add('begin');
- Add(' VK:=0;');
- Add(' for VI:=1 to count do');
- Add(' begin');
- Add(' for vj:=1 to vi do');
- Add(' begin');
- Add(' vk:=VK+VI;');
- Add(' end;');
- Add(' end;');
- Add('end;');
- Add('begin');
- Add(' sumnumbers(3);');
- ConvertProgram;
- CheckSource('TestForLoopInFunction',
- LinesToStr([ // statements
- 'this.SumNumbers = function (Count) {',
- ' var Result = 0;',
- ' var vI = 0;',
- ' var vJ = 0;',
- ' var vK = 0;',
- ' vK = 0;',
- ' for (var $l = 1, $end = Count; $l <= $end; $l++) {',
- ' vI = $l;',
- ' for (var $l1 = 1, $end1 = vI; $l1 <= $end1; $l1++) {',
- ' vJ = $l1;',
- ' vK = vK + vI;',
- ' };',
- ' };',
- ' return Result;',
- '};'
- ]),
- LinesToStr([ // $mod.$main
- ' $mod.SumNumbers(3);'
- ]));
- end;
- procedure TTestModule.TestRepeatUntil;
- begin
- StartProgram(false);
- Add('var');
- Add(' vI, vJ, vN: longint;');
- Add('begin');
- Add(' vn:=3;');
- Add(' vj:=0;');
- Add(' VI:=0;');
- Add(' repeat');
- Add(' VI:=vi+1;');
- Add(' vj:=VJ+vI;');
- Add(' until vi>=vn');
- ConvertProgram;
- CheckSource('TestRepeatUntil',
- LinesToStr([ // statements
- 'this.vI = 0;',
- 'this.vJ = 0;',
- 'this.vN = 0;'
- ]),
- LinesToStr([ // $mod.$main
- ' $mod.vN = 3;',
- ' $mod.vJ = 0;',
- ' $mod.vI = 0;',
- ' do{',
- ' $mod.vI = $mod.vI + 1;',
- ' $mod.vJ = $mod.vJ + $mod.vI;',
- ' }while(!($mod.vI>=$mod.vN));'
- ]));
- end;
- procedure TTestModule.TestAsmBlock;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' vI: longint;',
- 'begin',
- ' vi:=1;',
- ' asm',
- ' if (vI===1) {',
- ' vI=2;',
- //' console.log(''end;'');', ToDo
- ' }',
- ' if (vI===2){ vI=3; }',
- ' end;',
- ' VI:=4;']);
- ConvertProgram;
- CheckSource('TestAsmBlock',
- LinesToStr([ // statements
- 'this.vI = 0;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.vI = 1;',
- 'if (vI===1) {',
- ' vI=2;',
- '}',
- 'if (vI===2){ vI=3; }',
- ';',
- '$mod.vI = 4;'
- ]));
- end;
- procedure TTestModule.TestAsmPas_Impl;
- begin
- StartUnit(false);
- Add('interface');
- Add('const cIntf: longint = 1;');
- Add('var vIntf: longint;');
- Add('implementation');
- Add('const cImpl: longint = 2;');
- Add('var vImpl: longint;');
- Add('procedure DoIt;');
- Add('const cLoc: longint = 3;');
- Add('var vLoc: longint;');
- Add('begin;');
- Add(' asm');
- //Add(' pas(vIntf)=pas(cIntf);');
- //Add(' pas(vImpl)=pas(cImpl);');
- //Add(' pas(vLoc)=pas(cLoc);');
- Add(' end;');
- Add('end;');
- ConvertUnit;
- CheckSource('TestAsmPas_Impl',
- LinesToStr([
- 'var $impl = $mod.$impl;',
- 'this.cIntf = 1;',
- 'this.vIntf = 0;',
- '']),
- '', // this.$init
- LinesToStr([ // implementation
- '$impl.cImpl = 2;',
- '$impl.vImpl = 0;',
- 'var cLoc = 3;',
- '$impl.DoIt = function () {',
- ' var vLoc = 0;',
- '};',
- '']) );
- end;
- procedure TTestModule.TestTryFinally;
- begin
- StartProgram(false);
- Add('var i: longint;');
- Add('begin');
- Add(' try');
- Add(' i:=0; i:=2 div i;');
- Add(' finally');
- Add(' i:=3');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestTryFinally',
- LinesToStr([ // statements
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'try {',
- ' $mod.i = 0;',
- ' $mod.i = rtl.trunc(2 / $mod.i);',
- '} finally {',
- ' $mod.i = 3;',
- '};'
- ]));
- end;
- procedure TTestModule.TestTryExcept;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- ' Exception = class Msg: string; end;',
- ' EInvalidCast = class(Exception) end;',
- 'var vI: longint;',
- 'begin',
- ' try',
- ' vi:=1;',
- ' except',
- ' vi:=2',
- ' end;',
- ' try',
- ' vi:=3;',
- ' except',
- ' raise;',
- ' end;',
- ' try',
- ' VI:=4;',
- ' except',
- ' on einvalidcast do',
- ' raise;',
- ' on E: exception do',
- ' if e.msg='''' then',
- ' raise e;',
- ' else',
- ' vi:=5',
- ' end;',
- ' try',
- ' VI:=6;',
- ' except',
- ' on einvalidcast do ;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestTryExcept',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "Exception", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.Msg = "";',
- ' };',
- '});',
- 'rtl.createClass(this, "EInvalidCast", this.Exception, function () {',
- '});',
- 'this.vI = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'try {',
- ' $mod.vI = 1;',
- '} catch ($e) {',
- ' $mod.vI = 2;',
- '};',
- 'try {',
- ' $mod.vI = 3;',
- '} catch ($e) {',
- ' throw $e;',
- '};',
- 'try {',
- ' $mod.vI = 4;',
- '} catch ($e) {',
- ' if ($mod.EInvalidCast.isPrototypeOf($e)){',
- ' throw $e',
- ' } else if ($mod.Exception.isPrototypeOf($e)) {',
- ' var E = $e;',
- ' if (E.Msg === "") throw E;',
- ' } else {',
- ' $mod.vI = 5;',
- ' }',
- '};',
- 'try {',
- ' $mod.vI = 6;',
- '} catch ($e) {',
- ' if ($mod.EInvalidCast.isPrototypeOf($e)){' ,
- ' } else throw $e',
- '};',
- '']));
- end;
- procedure TTestModule.TestTryExcept_ReservedWords;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- ' Exception = class',
- ' Symbol: string;',
- ' end;',
- 'var &try: longint;',
- 'begin',
- ' try',
- ' &try:=4;',
- ' except',
- ' on Error: exception do',
- ' if errOR.symBol='''' then',
- ' raise ERRor;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestTryExcept_ReservedWords',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "Exception", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.Symbol = "";',
- ' };',
- '});',
- 'this.Try = 0;',
- '']),
- LinesToStr([ // $mod.$main
- 'try {',
- ' $mod.Try = 4;',
- '} catch ($e) {',
- ' if ($mod.Exception.isPrototypeOf($e)) {',
- ' var error = $e;',
- ' if (error.Symbol === "") throw error;',
- ' } else throw $e',
- '};',
- '']));
- end;
- procedure TTestModule.TestIfThenRaiseElse;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- 'constructor TObject.Create;',
- 'begin',
- 'end;',
- 'var b: boolean;',
- 'begin',
- ' if b then',
- ' raise TObject.Create',
- ' else',
- ' b:=false;',
- '']);
- ConvertProgram;
- CheckSource('TestIfThenRaiseElse',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- '});',
- 'this.b = false;',
- '']),
- LinesToStr([ // $mod.$main
- 'if ($mod.b) {',
- ' throw $mod.TObject.$create("Create")}',
- ' else $mod.b = false;',
- '']));
- end;
- procedure TTestModule.TestCaseOf;
- begin
- StartProgram(false);
- Add([
- 'const e: longint; external name ''$e'';',
- 'var vI: longint;',
- 'begin',
- ' case vi of',
- ' 1: ;',
- ' 2: vi:=3;',
- ' e: ;',
- ' else',
- ' VI:=4',
- ' end;']);
- ConvertProgram;
- CheckSource('TestCaseOf',
- LinesToStr([ // statements
- 'this.vI = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $tmp = $mod.vI;',
- 'if ($tmp === 1) {}',
- 'else if ($tmp === 2) {',
- ' $mod.vI = 3}',
- ' else if ($tmp === $e) {}',
- 'else {',
- ' $mod.vI = 4;',
- '};'
- ]));
- end;
- procedure TTestModule.TestCaseOf_UseSwitch;
- begin
- StartProgram(false);
- Converter.UseSwitchStatement:=true;
- Add('var Vi: longint;');
- Add('begin');
- Add(' case vi of');
- Add(' 1: ;');
- Add(' 2: VI:=3;');
- Add(' else');
- Add(' vi:=4');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestCaseOf_UseSwitch',
- LinesToStr([ // statements
- 'this.Vi = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'switch ($mod.Vi) {',
- 'case 1:',
- ' break;',
- 'case 2:',
- ' $mod.Vi = 3;',
- ' break;',
- 'default:',
- ' $mod.Vi = 4;',
- '};'
- ]));
- end;
- procedure TTestModule.TestCaseOfNoElse;
- begin
- StartProgram(false);
- Add('var Vi: longint;');
- Add('begin');
- Add(' case vi of');
- Add(' 1: begin vi:=2; VI:=3; end;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestCaseOfNoElse',
- LinesToStr([ // statements
- 'this.Vi = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $tmp = $mod.Vi;',
- 'if ($tmp === 1) {',
- ' $mod.Vi = 2;',
- ' $mod.Vi = 3;',
- '};'
- ]));
- end;
- procedure TTestModule.TestCaseOfNoElse_UseSwitch;
- begin
- StartProgram(false);
- Converter.UseSwitchStatement:=true;
- Add('var vI: longint;');
- Add('begin');
- Add(' case vi of');
- Add(' 1: begin VI:=2; vi:=3; end;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestCaseOfNoElse_UseSwitch',
- LinesToStr([ // statements
- 'this.vI = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'switch ($mod.vI) {',
- 'case 1:',
- ' $mod.vI = 2;',
- ' $mod.vI = 3;',
- ' break;',
- '};'
- ]));
- end;
- procedure TTestModule.TestCaseOfRange;
- begin
- StartProgram(false);
- Add('var vI: longint;');
- Add('begin');
- Add(' case vi of');
- Add(' 1..3: vi:=14;');
- Add(' 4,5: vi:=16;');
- Add(' 6..7,9..10: ;');
- Add(' else ;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestCaseOfRange',
- LinesToStr([ // statements
- 'this.vI = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $tmp = $mod.vI;',
- 'if (($tmp >= 1) && ($tmp <= 3)){',
- ' $mod.vI = 14',
- '} else if (($tmp === 4) || ($tmp === 5)){',
- ' $mod.vI = 16',
- '} else if ((($tmp >= 6) && ($tmp <= 7)) || (($tmp >= 9) && ($tmp <= 10))) ;'
- ]));
- end;
- procedure TTestModule.TestCaseOfString;
- begin
- StartProgram(false);
- Add([
- 'var s,h: string;',
- 'begin',
- ' case s of',
- ' ''foo'': s:=h;',
- ' ''a''..''z'': h:=s;',
- ' ''ў'', ''ё'': ;',
- ' ''Б''..''Я'': ;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestCaseOfString',
- LinesToStr([ // statements
- 'this.s = "";',
- 'this.h = "";',
- '']),
- LinesToStr([ // $mod.$main
- 'var $tmp = $mod.s;',
- 'if ($tmp === "foo") {',
- ' $mod.s = $mod.h}',
- ' else if (($tmp.length === 1) && ($tmp >= "a") && ($tmp <= "z")) {',
- ' $mod.h = $mod.s}',
- ' else if (($tmp === "ў") || ($tmp === "ё")) {}',
- ' else if (($tmp.length === 1) && ($tmp >= "Б") && ($tmp <= "Я")) ;',
- '']));
- end;
- procedure TTestModule.TestCaseOfChar;
- begin
- StartProgram(false);
- Add([
- 'var s,h: char;',
- 'begin',
- ' case s of',
- ' ''a''..''z'': h:=s;',
- ' ''ä'': ;',
- ' ''ў'', ''ё'': ;',
- ' ''Б''..''Я'': ;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestCaseOfString',
- LinesToStr([ // statements
- 'this.s = "";',
- 'this.h = "";',
- '']),
- LinesToStr([ // $mod.$main
- 'var $tmp = $mod.s;',
- 'if (($tmp >= "a") && ($tmp <= "z")) {',
- ' $mod.h = $mod.s}',
- ' else if ($tmp === "ä") {}',
- ' else if (($tmp === "ў") || ($tmp === "ё")) {}',
- ' else if (($tmp >= "Б") && ($tmp <= "Я")) ;',
- '']));
- end;
- procedure TTestModule.TestCaseOfExternalClassConst;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TBird = class external name ''Bird''',
- ' const e: longint;',
- ' end;',
- 'var vI: longint;',
- 'begin',
- ' case vi of',
- ' 1: vi:=3;',
- ' TBird.e: ;',
- ' end;']);
- ConvertProgram;
- CheckSource('TestCaseOfExternalClassConst',
- LinesToStr([ // statements
- 'this.vI = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $tmp = $mod.vI;',
- 'if ($tmp === 1) {',
- ' $mod.vI = 3}',
- ' else if ($tmp === Bird.e) ;'
- ]));
- end;
- procedure TTestModule.TestDebugger;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt;',
- 'begin',
- ' deBugger;',
- ' DeBugger();',
- 'end;',
- 'begin',
- ' Debugger;']);
- ConvertProgram;
- CheckSource('TestDebugger',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' debugger;',
- ' debugger;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- 'debugger;',
- '']));
- end;
- procedure TTestModule.TestArray_Dynamic;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrayInt = array of longint;',
- 'var',
- ' Arr: TArrayInt;',
- ' i: longint;',
- ' b: boolean;',
- 'begin',
- ' SetLength(arr,3);',
- ' arr[0]:=4;',
- ' arr[1]:=length(arr)+arr[0];',
- ' arr[i]:=5;',
- ' arr[arr[i]]:=arr[6];',
- ' i:=low(arr);',
- ' i:=high(arr);',
- ' b:=Assigned(arr);',
- ' Arr:=default(TArrayInt);']);
- ConvertProgram;
- CheckSource('TestArray_Dynamic',
- LinesToStr([ // statements
- 'this.Arr = [];',
- 'this.i = 0;',
- 'this.b = false;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Arr = rtl.arraySetLength($mod.Arr,0,3);',
- '$mod.Arr[0] = 4;',
- '$mod.Arr[1] = rtl.length($mod.Arr) + $mod.Arr[0];',
- '$mod.Arr[$mod.i] = 5;',
- '$mod.Arr[$mod.Arr[$mod.i]] = $mod.Arr[6];',
- '$mod.i = 0;',
- '$mod.i = rtl.length($mod.Arr) - 1;',
- '$mod.b = rtl.length($mod.Arr) > 0;',
- '$mod.Arr = [];',
- '']));
- end;
- procedure TTestModule.TestArray_Dynamic_Nil;
- begin
- StartProgram(false);
- Add('type');
- Add(' TArrayInt = array of longint;');
- Add('var');
- Add(' Arr: TArrayInt;');
- Add('procedure DoIt(const i: TArrayInt; j: TArrayInt); begin end;');
- Add('begin');
- Add(' arr:=nil;');
- Add(' if arr=nil then;');
- Add(' if nil=arr then;');
- Add(' if arr<>nil then;');
- Add(' if nil<>arr then;');
- Add(' DoIt(nil,nil);');
- ConvertProgram;
- CheckSource('TestArray_Dynamic',
- LinesToStr([ // statements
- 'this.Arr = [];',
- 'this.DoIt = function(i,j){',
- '};'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Arr = [];',
- 'if (rtl.length($mod.Arr) === 0) ;',
- 'if (rtl.length($mod.Arr) === 0) ;',
- 'if (rtl.length($mod.Arr) > 0) ;',
- 'if (rtl.length($mod.Arr) > 0) ;',
- '$mod.DoIt([],[]);',
- '']));
- end;
- procedure TTestModule.TestArray_DynMultiDimensional;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrayInt = array of longint;',
- ' TArrayArrayInt = array of TArrayInt;',
- 'var',
- ' Arr: TArrayInt;',
- ' Arr2: TArrayArrayInt;',
- ' i: longint;',
- 'begin',
- ' arr2:=nil;',
- ' if arr2=nil then;',
- ' if nil=arr2 then;',
- ' i:=low(arr2);',
- ' i:=low(arr2[1]);',
- ' i:=high(arr2);',
- ' i:=high(arr2[2]);',
- ' arr2[3]:=arr;',
- ' arr2[4][5]:=i;',
- ' i:=arr2[6][7];',
- ' arr2[8,9]:=i;',
- ' i:=arr2[10,11];',
- ' SetLength(arr2,14);',
- ' SetLength(arr2[15],16);']);
- ConvertProgram;
- CheckSource('TestArray_Dynamic',
- LinesToStr([ // statements
- 'this.Arr = [];',
- 'this.Arr2 = [];',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Arr2 = [];',
- 'if (rtl.length($mod.Arr2) === 0) ;',
- 'if (rtl.length($mod.Arr2) === 0) ;',
- '$mod.i = 0;',
- '$mod.i = 0;',
- '$mod.i = rtl.length($mod.Arr2) - 1;',
- '$mod.i = rtl.length($mod.Arr2[2]) - 1;',
- '$mod.Arr2[3] = rtl.arrayRef($mod.Arr);',
- '$mod.Arr2[4][5] = $mod.i;',
- '$mod.i = $mod.Arr2[6][7];',
- '$mod.Arr2[8][9] = $mod.i;',
- '$mod.i = $mod.Arr2[10][11];',
- '$mod.Arr2 = rtl.arraySetLength($mod.Arr2, [], 14);',
- '$mod.Arr2[15] = rtl.arraySetLength($mod.Arr2[15], 0, 16);',
- '']));
- end;
- procedure TTestModule.TestArray_DynamicAssign;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrayInt = array of longint;',
- ' TArrayArrayInt = array of TArrayInt;',
- 'procedure Run(a: TArrayInt; const b: TArrayInt; constref c: TArrayInt);',
- 'begin',
- 'end;',
- 'procedure Fly(var a: TArrayInt);',
- 'begin',
- 'end;',
- 'var',
- ' Arr: TArrayInt;',
- ' Arr2: TArrayArrayInt;',
- 'begin',
- ' arr:=nil;',
- ' arr2:=nil;',
- ' arr2[1]:=nil;',
- ' arr2[2]:=arr;',
- ' Run(arr,arr,arr);',
- ' Fly(arr);',
- ' Run(arr2[4],arr2[5],arr2[6]);',
- ' Fly(arr2[7]);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_DynamicAssign',
- LinesToStr([ // statements
- 'this.Run = function (a, b, c) {',
- '};',
- 'this.Fly = function (a) {',
- '};',
- 'this.Arr = [];',
- 'this.Arr2 = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Arr = [];',
- '$mod.Arr2 = [];',
- '$mod.Arr2[1] = [];',
- '$mod.Arr2[2] = rtl.arrayRef($mod.Arr);',
- '$mod.Run(rtl.arrayRef($mod.Arr), $mod.Arr, $mod.Arr);',
- '$mod.Fly({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.Arr;',
- ' },',
- ' set: function (v) {',
- ' this.p.Arr = v;',
- ' }',
- '});',
- '$mod.Run(rtl.arrayRef($mod.Arr2[4]), $mod.Arr2[5], $mod.Arr2[6]);',
- '$mod.Fly({',
- ' a: 7,',
- ' p: $mod.Arr2,',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- '});',
- '']));
- end;
- procedure TTestModule.TestArray_StaticInt;
- begin
- StartProgram(false);
- Add('type');
- Add(' TArrayInt = array[2..4] of longint;');
- Add('var');
- Add(' Arr: TArrayInt;');
- Add(' Arr2: TArrayInt = (5,6,7);');
- Add(' i: longint;');
- Add(' b: boolean;');
- Add('begin');
- Add(' arr[2]:=4;');
- Add(' arr[3]:=arr[2]+arr[3];');
- Add(' arr[i]:=5;');
- Add(' arr[arr[i]]:=arr[high(arr)];');
- Add(' i:=low(arr);');
- Add(' i:=high(arr);');
- Add(' b:=arr[2]=arr[3];');
- Add(' arr:=default(TArrayInt);');
- ConvertProgram;
- CheckSource('TestArray_StaticInt',
- LinesToStr([ // statements
- 'this.Arr = rtl.arraySetLength(null,0,3);',
- 'this.Arr2 = [5, 6, 7];',
- 'this.i = 0;',
- 'this.b = false;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Arr[0] = 4;',
- '$mod.Arr[1] = $mod.Arr[0] + $mod.Arr[1];',
- '$mod.Arr[$mod.i-2] = 5;',
- '$mod.Arr[$mod.Arr[$mod.i-2]-2] = $mod.Arr[2];',
- '$mod.i = 2;',
- '$mod.i = 4;',
- '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
- '$mod.Arr = rtl.arraySetLength(null,0,3);',
- '']));
- end;
- procedure TTestModule.TestArray_StaticBool;
- begin
- StartProgram(false);
- Add('type');
- Add(' TBools = array[boolean] of boolean;');
- Add(' TBool2 = array[true..true] of boolean;');
- Add('var');
- Add(' Arr: TBools;');
- Add(' Arr2: TBool2;');
- Add(' Arr3: TBools = (true,false);');
- Add(' b: boolean;');
- Add('begin');
- Add(' b:=low(arr);');
- Add(' b:=high(arr);');
- Add(' arr[true]:=false;');
- Add(' arr[false]:=arr[b] or arr[true];');
- Add(' arr[b]:=true;');
- Add(' arr[arr[b]]:=arr[high(arr)];');
- Add(' b:=arr[false]=arr[true];');
- Add(' b:=low(arr2);');
- Add(' b:=high(arr2);');
- Add(' arr2[true]:=true;');
- Add(' arr2[true]:=arr2[true] and arr2[b];');
- Add(' arr2[b]:=false;');
- ConvertProgram;
- CheckSource('TestArray_StaticBool',
- LinesToStr([ // statements
- 'this.Arr = rtl.arraySetLength(null,false,2);',
- 'this.Arr2 = rtl.arraySetLength(null,false,1);',
- 'this.Arr3 = [true, false];',
- 'this.b = false;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.b = false;',
- '$mod.b = true;',
- '$mod.Arr[1] = false;',
- '$mod.Arr[0] = $mod.Arr[+$mod.b] || $mod.Arr[1];',
- '$mod.Arr[+$mod.b] = true;',
- '$mod.Arr[+$mod.Arr[+$mod.b]] = $mod.Arr[1];',
- '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
- '$mod.b = true;',
- '$mod.b = true;',
- '$mod.Arr2[0] = true;',
- '$mod.Arr2[0] = $mod.Arr2[0] && $mod.Arr2[1-$mod.b];',
- '$mod.Arr2[1-$mod.b] = false;',
- '']));
- end;
- procedure TTestModule.TestArray_StaticChar;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TChars = array[char] of char;',
- ' TChars2 = array[''a''..''z''] of char;',
- 'var',
- ' Arr: TChars;',
- ' Arr2: TChars2;',
- ' Arr3: array[2..4] of char = (''p'',''a'',''s'');',
- ' Arr4: array[11..13] of char = ''pas'';',
- ' Arr5: array[21..22] of char = ''äö'';',
- ' Arr6: array[31..32] of char = ''ä''+''ö'';',
- ' c: char;',
- ' b: boolean;',
- 'begin',
- ' c:=low(arr);',
- ' c:=high(arr);',
- ' arr[''B'']:=''a'';',
- ' arr[''D'']:=arr[c];',
- ' arr[c]:=arr[''d''];',
- ' arr[arr[c]]:=arr[high(arr)];',
- ' b:=arr[low(arr)]=arr[''e''];',
- ' c:=low(arr2);',
- ' c:=high(arr2);',
- ' arr2[''b'']:=''f'';',
- ' arr2[''a'']:=arr2[c];',
- ' arr2[c]:=arr2[''g''];']);
- ConvertProgram;
- CheckSource('TestArray_StaticChar',
- LinesToStr([ // statements
- 'this.Arr = rtl.arraySetLength(null, "", 65536);',
- 'this.Arr2 = rtl.arraySetLength(null, "", 26);',
- 'this.Arr3 = ["p", "a", "s"];',
- 'this.Arr4 = ["p", "a", "s"];',
- 'this.Arr5 = ["ä", "ö"];',
- 'this.Arr6 = ["ä", "ö"];',
- 'this.c = "";',
- 'this.b = false;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.c = "\x00";',
- '$mod.c = "\uFFFF";',
- '$mod.Arr[66] = "a";',
- '$mod.Arr[68] = $mod.Arr[$mod.c.charCodeAt()];',
- '$mod.Arr[$mod.c.charCodeAt()] = $mod.Arr[100];',
- '$mod.Arr[$mod.Arr[$mod.c.charCodeAt()].charCodeAt()] = $mod.Arr[65535];',
- '$mod.b = $mod.Arr[0] === $mod.Arr[101];',
- '$mod.c = "a";',
- '$mod.c = "z";',
- '$mod.Arr2[1] = "f";',
- '$mod.Arr2[0] = $mod.Arr2[$mod.c.charCodeAt() - 97];',
- '$mod.Arr2[$mod.c.charCodeAt() - 97] = $mod.Arr2[6];',
- '']));
- end;
- procedure TTestModule.TestArray_StaticMultiDim;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrayInt = array[1..3] of longint;',
- ' TArrayArrayInt = array[5..6] of TArrayInt;',
- 'var',
- ' Arr: TArrayInt;',
- ' Arr2: TArrayArrayInt;',
- ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
- ' i: longint;',
- 'begin',
- ' i:=low(arr);',
- ' i:=low(arr2);',
- ' i:=low(arr2[5]);',
- ' i:=high(arr);',
- ' i:=high(arr2);',
- ' i:=high(arr2[6]);',
- ' arr2[5]:=arr;',
- ' arr2[6][2]:=i;',
- ' i:=arr2[6][3];',
- ' arr2[6,3]:=i;',
- ' i:=arr2[5,2];',
- ' arr2:=arr2;',// clone multi dim static array
- ' arr3:=arr3;',// clone anonymous multi dim static array
- '']);
- ConvertProgram;
- CheckSource('TestArray_StaticMultiDim',
- LinesToStr([ // statements
- 'this.TArrayArrayInt$clone = function (a) {',
- ' var r = [];',
- ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
- ' return r;',
- '};',
- 'this.Arr = rtl.arraySetLength(null, 0, 3);',
- 'this.Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
- 'this.Arr3$a$clone = function (a) {',
- ' var r = [];',
- ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
- ' return r;',
- '};',
- 'this.Arr3 = [[11, 12, 13], [21, 22, 23]];',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.i = 1;',
- '$mod.i = 5;',
- '$mod.i = 1;',
- '$mod.i = 3;',
- '$mod.i = 6;',
- '$mod.i = 3;',
- '$mod.Arr2[0] = $mod.Arr.slice(0);',
- '$mod.Arr2[1][1] = $mod.i;',
- '$mod.i = $mod.Arr2[1][2];',
- '$mod.Arr2[1][2] = $mod.i;',
- '$mod.i = $mod.Arr2[0][1];',
- '$mod.Arr2 = $mod.TArrayArrayInt$clone($mod.Arr2);',
- '$mod.Arr3 = $mod.Arr3$a$clone($mod.Arr3);',
- '']));
- end;
- procedure TTestModule.TestArray_StaticInFunction;
- begin
- StartProgram(false);
- Add([
- 'const TArrayInt = 3;',
- 'const TArrayArrayInt = 4;',
- 'procedure DoIt;',
- 'type',
- ' TArrayInt = array[1..3] of longint;',
- ' TArrayArrayInt = array[5..6] of TArrayInt;',
- 'var',
- ' Arr: TArrayInt;',
- ' Arr2: TArrayArrayInt;',
- ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
- ' i: longint;',
- 'begin',
- ' arr2[5]:=arr;',
- ' arr2:=arr2;',// clone multi dim static array
- ' arr3:=arr3;',// clone multi dim anonymous static array
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestArray_StaticInFunction',
- LinesToStr([ // statements
- 'this.TArrayInt = 3;',
- 'this.TArrayArrayInt = 4;',
- 'var TArrayArrayInt$1$clone = function (a) {',
- ' var r = [];',
- ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
- ' return r;',
- '};',
- 'var Arr3$a$clone = function (a) {',
- ' var r = [];',
- ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
- ' return r;',
- '};',
- 'this.DoIt = function () {',
- ' var Arr = rtl.arraySetLength(null, 0, 3);',
- ' var Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
- ' var Arr3 = [[11, 12, 13], [21, 22, 23]];',
- ' var i = 0;',
- ' Arr2[0] = Arr.slice(0);',
- ' Arr2 = TArrayArrayInt$1$clone(Arr2);',
- ' Arr3 = Arr3$a$clone(Arr3);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestArray_StaticMultiDimEqualNotImplemented;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrayInt = array[1..3,1..2] of longint;',
- 'var',
- ' a,b: TArrayInt;',
- 'begin',
- ' if a=b then ;',
- '']);
- SetExpectedPasResolverError('compare static array is not supported',
- nXIsNotSupported);
- ConvertProgram;
- end;
- procedure TTestModule.TestArrayOfRecord;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TRec = record',
- ' Int: longint;',
- ' end;',
- ' TArrayRec = array of TRec;',
- 'procedure DoIt(vd: TRec; const vc: TRec; var vv: TRec);',
- 'begin',
- 'end;',
- 'var',
- ' Arr: TArrayRec;',
- ' r: TRec;',
- ' i: longint;',
- 'begin',
- ' SetLength(arr,3);',
- ' arr[0].int:=4;',
- ' arr[1].int:=length(arr)+arr[2].int;',
- ' arr[arr[i].int].int:=arr[5].int;',
- ' arr[7]:=r;',
- ' r:=arr[8];',
- ' i:=low(arr);',
- ' i:=high(arr);',
- ' DoIt(Arr[9],Arr[10],Arr[11]);']);
- ConvertProgram;
- CheckSource('TestArrayOfRecord',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.Int = 0;',
- ' this.$eq = function (b) {',
- ' return this.Int === b.Int;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Int = s.Int;',
- ' return this;',
- ' };',
- '});',
- 'this.DoIt = function (vd, vc, vv) {',
- '};',
- 'this.Arr = [];',
- 'this.r = this.TRec.$new();',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Arr = rtl.arraySetLength($mod.Arr,$mod.TRec,3);',
- '$mod.Arr[0].Int = 4;',
- '$mod.Arr[1].Int = rtl.length($mod.Arr)+$mod.Arr[2].Int;',
- '$mod.Arr[$mod.Arr[$mod.i].Int].Int = $mod.Arr[5].Int;',
- '$mod.Arr[7].$assign($mod.r);',
- '$mod.r.$assign($mod.Arr[8]);',
- '$mod.i = 0;',
- '$mod.i = rtl.length($mod.Arr)-1;',
- '$mod.DoIt($mod.TRec.$clone($mod.Arr[9]), $mod.Arr[10], $mod.Arr[11]);',
- '']));
- end;
- procedure TTestModule.TestArray_StaticRecord;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TRec = record',
- ' Int: longint;',
- ' end;',
- ' TArrayRec = array[1..2] of TRec;',
- 'var',
- ' Arr: TArrayRec;',
- 'begin',
- ' arr[1].int:=length(arr)+low(arr)+high(arr);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_StaticRecord',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.Int = 0;',
- ' this.$eq = function (b) {',
- ' return this.Int === b.Int;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Int = s.Int;',
- ' return this;',
- ' };',
- '});',
- 'this.TArrayRec$clone = function (a) {',
- ' var r = [];',
- ' for (var i = 0; i < 2; i++) r.push($mod.TRec.$clone(a[i]));',
- ' return r;',
- '};',
- 'this.Arr = rtl.arraySetLength(null, this.TRec, 2);',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Arr[0].Int = 2 + 1 + 2;']));
- end;
- procedure TTestModule.TestArrayOfSet;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TFlag = (big,small);',
- ' TSetOfFlag = set of tflag;',
- ' TArrayFlag = array of TSetOfFlag;',
- 'procedure DoIt(const a: Tarrayflag);',
- 'begin',
- 'end;',
- 'var',
- ' f: TFlag;',
- ' s: TSetOfFlag;',
- ' Arr: TArrayFlag;',
- ' i: longint;',
- 'begin',
- ' SetLength(arr,3);',
- ' arr[0]:=s;',
- ' arr[1]:=[big];',
- ' arr[2]:=[big]+s;',
- ' arr[3]:=s+[big];',
- ' arr[4]:=arr[5];',
- ' s:=arr[6];',
- ' i:=low(arr);',
- ' i:=high(arr);',
- ' DoIt(arr);',
- ' DoIt([s]);',
- ' DoIt([[],s]);',
- ' DoIt([s,[]]);',
- '']);
- ConvertProgram;
- CheckSource('TestArrayOfSet',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "big",',
- ' big: 0,',
- ' "1": "small",',
- ' small: 1',
- '};',
- 'this.DoIt = function (a) {',
- '};',
- 'this.f = 0;',
- 'this.s = {};',
- 'this.Arr = [];',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Arr = rtl.arraySetLength($mod.Arr, {}, 3);',
- '$mod.Arr[0] = rtl.refSet($mod.s);',
- '$mod.Arr[1] = rtl.createSet($mod.TFlag.big);',
- '$mod.Arr[2] = rtl.unionSet(rtl.createSet($mod.TFlag.big), $mod.s);',
- '$mod.Arr[3] = rtl.unionSet($mod.s, rtl.createSet($mod.TFlag.big));',
- '$mod.Arr[4] = rtl.refSet($mod.Arr[5]);',
- '$mod.s = rtl.refSet($mod.Arr[6]);',
- '$mod.i = 0;',
- '$mod.i = rtl.length($mod.Arr) - 1;',
- '$mod.DoIt($mod.Arr);',
- '$mod.DoIt([rtl.refSet($mod.s)]);',
- '$mod.DoIt([{}, rtl.refSet($mod.s)]);',
- '$mod.DoIt([rtl.refSet($mod.s), {}]);',
- '']));
- end;
- procedure TTestModule.TestArray_DynAsParam;
- begin
- StartProgram(false);
- Add([
- 'type integer = longint;',
- 'type TArrInt = array of integer;',
- 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
- 'var vJ: TArrInt;',
- 'begin',
- ' vg:=vg;',
- ' vj:=vh;',
- ' vi:=vi;',
- ' doit(vg,vg,vg);',
- ' doit(vh,vh,vj);',
- ' doit(vi,vi,vi);',
- ' doit(vj,vj,vj);',
- 'end;',
- 'var i: TArrInt;',
- 'begin',
- ' doit(i,i,i);']);
- ConvertProgram;
- CheckSource('TestArray_DynAsParams',
- LinesToStr([ // statements
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = [];',
- ' vG = rtl.arrayRef(vG);',
- ' vJ = rtl.arrayRef(vH);',
- ' vI.set(rtl.arrayRef(vI.get()));',
- ' $mod.DoIt(rtl.arrayRef(vG), vG, {',
- ' get: function () {',
- ' return vG;',
- ' },',
- ' set: function (v) {',
- ' vG = v;',
- ' }',
- ' });',
- ' $mod.DoIt(rtl.arrayRef(vH), vH, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- ' $mod.DoIt(rtl.arrayRef(vI.get()), vI.get(), vI);',
- ' $mod.DoIt(rtl.arrayRef(vJ), vJ, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- '};',
- 'this.i = [];'
- ]),
- LinesToStr([
- '$mod.DoIt(rtl.arrayRef($mod.i),$mod.i,{',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});'
- ]));
- end;
- procedure TTestModule.TestArray_StaticAsParam;
- begin
- StartProgram(false);
- Add([
- 'type integer = longint;',
- 'type TArrInt = array[1..2] of integer;',
- 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
- 'var vJ: TArrInt;',
- 'begin',
- ' vg:=vg;',
- ' vj:=vh;',
- ' vi:=vi;',
- ' doit(vg,vg,vg);',
- ' doit(vh,vh,vj);',
- ' doit(vi,vi,vi);',
- ' doit(vj,vj,vj);',
- 'end;',
- 'var i: TArrInt;',
- 'begin',
- ' doit(i,i,i);']);
- ConvertProgram;
- CheckSource('TestArray_StaticAsParams',
- LinesToStr([ // statements
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = rtl.arraySetLength(null, 0, 2);',
- ' vG = vG.slice(0);',
- ' vJ = vH.slice(0);',
- ' vI.set(vI.get().slice(0));',
- ' $mod.DoIt(vG.slice(0), vG, {',
- ' get: function () {',
- ' return vG;',
- ' },',
- ' set: function (v) {',
- ' vG = v;',
- ' }',
- ' });',
- ' $mod.DoIt(vH.slice(0), vH, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- ' $mod.DoIt(vI.get().slice(0), vI.get(), vI);',
- ' $mod.DoIt(vJ.slice(0), vJ, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- '};',
- 'this.i = rtl.arraySetLength(null, 0, 2);'
- ]),
- LinesToStr([
- '$mod.DoIt($mod.i.slice(0),$mod.i,{',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});'
- ]));
- end;
- procedure TTestModule.TestArrayElement_AsParams;
- begin
- StartProgram(false);
- Add('type integer = longint;');
- Add('type TArrayInt = array of integer;');
- Add('procedure DoIt(vG: Integer; const vH: Integer; var vI: Integer);');
- Add('var vJ: tarrayint;');
- Add('begin');
- Add(' vi:=vi;');
- Add(' doit(vi,vi,vi);');
- Add(' doit(vj[1+1],vj[1+2],vj[1+3]);');
- Add('end;');
- Add('var a: TArrayInt;');
- Add('begin');
- Add(' doit(a[1+4],a[1+5],a[1+6]);');
- ConvertProgram;
- CheckSource('TestArrayElement_AsParams',
- LinesToStr([ // statements
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = [];',
- ' vI.set(vI.get());',
- ' $mod.DoIt(vI.get(), vI.get(), vI);',
- ' $mod.DoIt(vJ[1+1], vJ[1+2], {',
- ' a:1+3,',
- ' p:vJ,',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- ' });',
- '};',
- 'this.a = [];'
- ]),
- LinesToStr([
- '$mod.DoIt($mod.a[1+4],$mod.a[1+5],{',
- ' a: 1+6,',
- ' p: $mod.a,',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- '});'
- ]));
- end;
- procedure TTestModule.TestArrayElementFromFuncResult_AsParams;
- begin
- StartProgram(false);
- Add('type Integer = longint;');
- Add('type TArrayInt = array of integer;');
- Add('function GetArr(vB: integer = 0): tarrayint;');
- Add('begin');
- Add('end;');
- Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
- Add('begin');
- Add('end;');
- Add('begin');
- Add(' doit(getarr[1+1],getarr[1+2],getarr[1+3]);');
- Add(' doit(getarr()[2+1],getarr()[2+2],getarr()[2+3]);');
- Add(' doit(getarr(7)[3+1],getarr(8)[3+2],getarr(9)[3+3]);');
- ConvertProgram;
- CheckSource('TestArrayElementFromFuncResult_AsParams',
- LinesToStr([ // statements
- 'this.GetArr = function (vB) {',
- ' var Result = [];',
- ' return Result;',
- '};',
- 'this.DoIt = function (vG,vH,vI) {',
- '};'
- ]),
- LinesToStr([
- '$mod.DoIt($mod.GetArr(0)[1+1],$mod.GetArr(0)[1+2],{',
- ' a: 1+3,',
- ' p: $mod.GetArr(0),',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- '});',
- '$mod.DoIt($mod.GetArr(0)[2+1],$mod.GetArr(0)[2+2],{',
- ' a: 2+3,',
- ' p: $mod.GetArr(0),',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- '});',
- '$mod.DoIt($mod.GetArr(7)[3+1],$mod.GetArr(8)[3+2],{',
- ' a: 3+3,',
- ' p: $mod.GetArr(9),',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- '});',
- '']));
- end;
- procedure TTestModule.TestArrayEnumTypeRange;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (red,blue);',
- ' TEnumArray = array[TEnum] of longint;',
- 'var',
- ' e: TEnum;',
- ' i: longint;',
- ' a: TEnumArray;',
- ' numbers: TEnumArray = (1,2);',
- ' names: array[TEnum] of string = (''red'',''blue'');',
- 'begin',
- ' e:=low(a);',
- ' e:=high(a);',
- ' i:=a[red];',
- ' a[e]:=a[e];']);
- ConvertProgram;
- CheckSource('TestArrayEnumTypeRange',
- LinesToStr([ // statements
- ' this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'this.e = 0;',
- 'this.i = 0;',
- 'this.a = rtl.arraySetLength(null,0,2);',
- 'this.numbers = [1, 2];',
- 'this.names = ["red", "blue"];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.e = $mod.TEnum.red;',
- '$mod.e = $mod.TEnum.blue;',
- '$mod.i = $mod.a[$mod.TEnum.red];',
- '$mod.a[$mod.e] = $mod.a[$mod.e];',
- '']));
- end;
- procedure TTestModule.TestArray_SetLengthOutArg;
- begin
- StartProgram(false);
- Add([
- 'type TArrInt = array of longint;',
- 'procedure DoIt(out a: TArrInt);',
- 'begin',
- ' SetLength(a,2);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestArray_SetLengthOutArg',
- LinesToStr([ // statements
- 'this.DoIt = function (a) {',
- ' a.set(rtl.arraySetLength(a.get(), 0, 2));',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestArray_SetLengthProperty;
- begin
- StartProgram(false);
- Add('type');
- Add(' TArrInt = array of longint;');
- Add(' TObject = class');
- Add(' function GetColors: TArrInt; external name ''GetColors'';');
- Add(' procedure SetColors(const Value: TArrInt); external name ''SetColors'';');
- Add(' property Colors: TArrInt read GetColors write SetColors;');
- Add(' end;');
- Add('var Obj: TObject;');
- Add('begin');
- Add(' SetLength(Obj.Colors,2);');
- ConvertProgram;
- CheckSource('TestArray_SetLengthProperty',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.Obj = null;',
- '']),
- LinesToStr([
- '$mod.Obj.SetColors(rtl.arraySetLength($mod.Obj.GetColors(), 0, 2));',
- '']));
- end;
- procedure TTestModule.TestArray_SetLengthMultiDim;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrArrInt = array of array of longint;',
- ' TArrStaInt = array of array[1..2] of longint;',
- 'var',
- ' a: TArrArrInt;',
- ' b: TArrStaInt;',
- 'begin',
- ' SetLength(a,2);',
- ' SetLength(a,3,4);',
- ' SetLength(b,5);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_SetLengthMultiDim',
- LinesToStr([ // statements
- 'this.a = [];',
- 'this.b = [];',
- '']),
- LinesToStr([
- '$mod.a = rtl.arraySetLength($mod.a, [], 2);',
- '$mod.a = rtl.arraySetLength($mod.a, 0, 3, 4);',
- '$mod.b = rtl.arraySetLength($mod.b, 0, 5, "s", 2);',
- '']));
- end;
- procedure TTestModule.TestArray_SetLengthDynOfStatic;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TStaArr1 = array[1..3] of boolean;',
- //' TStaArr2 = array[5..6] of TStaArr1;',
- ' TDynArr1StaArr1 = array of TStaArr1;',
- //' TDynArr1StaArr2 = array of TStaArr2;',
- ' TDynArr2StaArr1 = array of TDynArr1StaArr1;',
- //' TDynArr2StaArr2 = array of TDynArr1StaArr2;',
- 'var',
- ' DynArr1StaArr1: TDynArr1StaArr1;',
- //' DynArr1StaArr2: TDynArr1StaArr1;',
- ' DynArr2StaArr1: TDynArr2StaArr1;',
- //' DynArr2StaArr2: TDynArr2StaArr2;',
- 'begin',
- ' SetLength(DynArr1StaArr1,11);',
- ' SetLength(DynArr2StaArr1,12);',
- ' SetLength(DynArr2StaArr1[13],14);',
- ' SetLength(DynArr2StaArr1,15,16);',
- //' SetLength(DynArr1StaArr2,21);',
- //' SetLength(DynArr2StaArr2,22);',
- //' SetLength(DynArr2StaArr2[23],24);',
- //' SetLength(DynArr2StaArr2,25,26);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_DynOfStatic',
- LinesToStr([ // statements
- 'this.DynArr1StaArr1 = [];',
- 'this.DynArr2StaArr1 = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DynArr1StaArr1 = rtl.arraySetLength($mod.DynArr1StaArr1, false, 11, "s", 3);',
- '$mod.DynArr2StaArr1 = rtl.arraySetLength($mod.DynArr2StaArr1, [], 12);',
- '$mod.DynArr2StaArr1[13] = rtl.arraySetLength($mod.DynArr2StaArr1[13], false, 14, "s", 3);',
- '$mod.DynArr2StaArr1 = rtl.arraySetLength(',
- ' $mod.DynArr2StaArr1,',
- ' false,',
- ' 15,',
- ' 16,',
- ' "s",',
- ' 3',
- ');',
- '']));
- end;
- procedure TTestModule.TestArray_OpenArrayOfString;
- begin
- StartProgram(false);
- Add('procedure DoIt(const a: array of String);');
- Add('var');
- Add(' i: longint;');
- Add(' s: string;');
- Add('begin');
- Add(' for i:=low(a) to high(a) do s:=a[length(a)-i-1];');
- Add('end;');
- Add('var s: string;');
- Add('begin');
- Add(' DoIt([]);');
- Add(' DoIt([s,''foo'','''',s+s]);');
- ConvertProgram;
- CheckSource('TestArray_OpenArrayOfString',
- LinesToStr([ // statements
- 'this.DoIt = function (a) {',
- ' var i = 0;',
- ' var s = "";',
- ' for (var $l = 0, $end = rtl.length(a) - 1; $l <= $end; $l++) {',
- ' i = $l;',
- ' s = a[rtl.length(a) - i - 1];',
- ' };',
- '};',
- 'this.s = "";',
- '']),
- LinesToStr([
- '$mod.DoIt([]);',
- '$mod.DoIt([$mod.s, "foo", "", $mod.s + $mod.s]);',
- '']));
- end;
- procedure TTestModule.TestArray_ArrayOfCharAssignString;
- begin
- StartProgram(false);
- Add([
- 'type TArr = array of char;',
- 'var',
- ' c: char;',
- ' s: string;',
- ' a: TArr;',
- 'procedure Run(const a: array of char);',
- 'begin',
- ' Run(c);',
- ' Run(s);',
- 'end;',
- 'begin',
- ' a:=c;',
- ' a:=s;',
- ' a:=#13;',
- ' a:=''Foo'';',
- ' Run(c);',
- ' Run(s);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_ArrayOfCharAssignString',
- LinesToStr([ // statements
- 'this.c = "";',
- 'this.s = "";',
- 'this.a = [];',
- 'this.Run = function (a) {',
- ' $mod.Run($mod.c.split(""));',
- ' $mod.Run($mod.s.split(""));',
- '};',
- '']),
- LinesToStr([
- '$mod.a = $mod.c.split("");',
- '$mod.a = $mod.s.split("");',
- '$mod.a = "\r".split("");',
- '$mod.a = "Foo".split("");',
- '$mod.Run($mod.c.split(""));',
- '$mod.Run($mod.s.split(""));',
- '']));
- end;
- procedure TTestModule.TestArray_ConstRef;
- begin
- StartProgram(false);
- Add([
- 'type TArr = array of word;',
- 'procedure Run(constref a: TArr);',
- 'begin',
- 'end;',
- 'procedure Fly(a: TArr; var b: TArr; out c: TArr; const d: TArr; constref e: TArr);',
- 'var l: TArr;',
- 'begin',
- ' Run(l);',
- ' Run(a);',
- ' Run(b);',
- ' Run(c);',
- ' Run(d);',
- ' Run(e);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckResolverUnexpectedHints();
- CheckSource('TestArray_ConstRef',
- LinesToStr([ // statements
- 'this.Run = function (a) {',
- '};',
- 'this.Fly = function (a, b, c, d, e) {',
- ' var l = [];',
- ' $mod.Run(l);',
- ' $mod.Run(a);',
- ' $mod.Run(b.get());',
- ' $mod.Run(c.get());',
- ' $mod.Run(d);',
- ' $mod.Run(e);',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestArray_Concat;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' TFlag = (big,small);',
- ' TFlags = set of TFlag;',
- ' TRec = record',
- ' i: integer;',
- ' end;',
- ' TArrInt = array of integer;',
- ' TArrRec = array of TRec;',
- ' TArrFlag = array of TFlag;',
- ' TArrSet = array of TFlags;',
- ' TArrJSValue = array of jsvalue;',
- 'var',
- ' ArrInt: tarrint;',
- ' ArrRec: tarrrec;',
- ' ArrFlag: tarrflag;',
- ' ArrSet: tarrset;',
- ' ArrJSValue: tarrjsvalue;',
- 'begin',
- ' arrint:=concat(arrint);',
- ' arrint:=concat(arrint,arrint);',
- ' arrint:=concat(arrint,arrint,arrint);',
- ' arrrec:=concat(arrrec);',
- ' arrrec:=concat(arrrec,arrrec);',
- ' arrrec:=concat(arrrec,arrrec,arrrec);',
- ' arrset:=concat(arrset);',
- ' arrset:=concat(arrset,arrset);',
- ' arrset:=concat(arrset,arrset,arrset);',
- ' arrjsvalue:=concat(arrjsvalue);',
- ' arrjsvalue:=concat(arrjsvalue,arrjsvalue);',
- ' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);',
- ' arrint:=concat([1],arrint);',
- ' arrflag:=concat([big]);',
- ' arrflag:=concat([big],arrflag);',
- ' arrflag:=concat(arrflag,[small]);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_Concat',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "big",',
- ' big: 0,',
- ' "1": "small",',
- ' small: 1',
- '};',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.ArrInt = [];',
- 'this.ArrRec = [];',
- 'this.ArrFlag = [];',
- 'this.ArrSet = [];',
- 'this.ArrJSValue = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ArrInt = rtl.arrayRef($mod.ArrInt);',
- '$mod.ArrInt = rtl.arrayConcatN($mod.ArrInt, $mod.ArrInt);',
- '$mod.ArrInt = rtl.arrayConcatN($mod.ArrInt, $mod.ArrInt, $mod.ArrInt);',
- '$mod.ArrRec = rtl.arrayRef($mod.ArrRec);',
- '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec);',
- '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec, $mod.ArrRec);',
- '$mod.ArrSet = rtl.arrayRef($mod.ArrSet);',
- '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet);',
- '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet, $mod.ArrSet);',
- '$mod.ArrJSValue = rtl.arrayRef($mod.ArrJSValue);',
- '$mod.ArrJSValue = rtl.arrayConcatN($mod.ArrJSValue, $mod.ArrJSValue);',
- '$mod.ArrJSValue = rtl.arrayConcatN($mod.ArrJSValue, $mod.ArrJSValue, $mod.ArrJSValue);',
- '$mod.ArrInt = rtl.arrayConcatN([1], $mod.ArrInt);',
- '$mod.ArrFlag = [$mod.TFlag.big];',
- '$mod.ArrFlag = rtl.arrayConcatN([$mod.TFlag.big], $mod.ArrFlag);',
- '$mod.ArrFlag = rtl.arrayConcatN($mod.ArrFlag, [$mod.TFlag.small]);',
- '']));
- end;
- procedure TTestModule.TestArray_Copy;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' TFlag = (big,small);',
- ' TFlags = set of TFlag;',
- ' TRec = record',
- ' i: integer;',
- ' end;',
- ' TArrInt = array of integer;',
- ' TArrRec = array of TRec;',
- ' TArrSet = array of TFlags;',
- ' TArrJSValue = array of jsvalue;',
- 'var',
- ' ArrInt: tarrint;',
- ' ArrRec: tarrrec;',
- ' ArrSet: tarrset;',
- ' ArrJSValue: tarrjsvalue;',
- 'begin',
- ' arrint:=copy(arrint);',
- ' arrint:=copy(arrint,2);',
- ' arrint:=copy(arrint,3,4);',
- ' arrint:=copy([1,1],1,2);',
- ' arrrec:=copy(arrrec);',
- ' arrrec:=copy(arrrec,5);',
- ' arrrec:=copy(arrrec,6,7);',
- ' arrset:=copy(arrset);',
- ' arrset:=copy(arrset,8);',
- ' arrset:=copy(arrset,9,10);',
- ' arrjsvalue:=copy(arrjsvalue);',
- ' arrjsvalue:=copy(arrjsvalue,11);',
- ' arrjsvalue:=copy(arrjsvalue,12,13);',
- ' ']);
- ConvertProgram;
- CheckSource('TestArray_Copy',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "big",',
- ' big: 0,',
- ' "1": "small",',
- ' small: 1',
- '};',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.ArrInt = [];',
- 'this.ArrRec = [];',
- 'this.ArrSet = [];',
- 'this.ArrJSValue = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 0);',
- '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 2);',
- '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 3, 4);',
- '$mod.ArrInt = rtl.arrayCopy(0, [1, 1], 1, 2);',
- '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 0);',
- '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 5);',
- '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 6, 7);',
- '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 0);',
- '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 8);',
- '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 9, 10);',
- '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 0);',
- '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 11);',
- '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 12, 13);',
- '']));
- end;
- procedure TTestModule.TestArray_InsertDelete;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' TFlag = (big,small);',
- ' TFlags = set of TFlag;',
- ' TRec = record',
- ' i: integer;',
- ' end;',
- ' TArrInt = array of integer;',
- ' TArrRec = array of TRec;',
- ' TArrSet = array of TFlags;',
- ' TArrJSValue = array of jsvalue;',
- ' TArrArrInt = array of TArrInt;',
- 'var',
- ' ArrInt: tarrint;',
- ' ArrRec: tarrrec;',
- ' ArrSet: tarrset;',
- ' ArrJSValue: tarrjsvalue;',
- ' ArrArrInt: TArrArrInt;',
- 'begin',
- ' Insert(1,arrint,2);',
- ' Insert(arrint[3],arrint,4);',
- ' Insert(arrrec[5],arrrec,6);',
- ' Insert(arrset[7],arrset,7);',
- ' Insert(arrjsvalue[8],arrjsvalue,9);',
- ' Insert(10,arrjsvalue,11);',
- ' Insert([23],arrarrint,22);',
- ' Delete(arrint,12,13);',
- ' Delete(arrrec,14,15);',
- ' Delete(arrset,17,18);',
- ' Delete(arrjsvalue,19,10);']);
- ConvertProgram;
- CheckSource('TestArray_InsertDelete',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "big",',
- ' big: 0,',
- ' "1": "small",',
- ' small: 1',
- '};',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.ArrInt = [];',
- 'this.ArrRec = [];',
- 'this.ArrSet = [];',
- 'this.ArrJSValue = [];',
- 'this.ArrArrInt = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ArrInt = rtl.arrayInsert(1, $mod.ArrInt, 2);',
- '$mod.ArrInt = rtl.arrayInsert($mod.ArrInt[3], $mod.ArrInt, 4);',
- '$mod.ArrRec = rtl.arrayInsert($mod.ArrRec[5], $mod.ArrRec, 6);',
- '$mod.ArrSet = rtl.arrayInsert($mod.ArrSet[7], $mod.ArrSet, 7);',
- '$mod.ArrJSValue = rtl.arrayInsert($mod.ArrJSValue[8], $mod.ArrJSValue, 9);',
- '$mod.ArrJSValue = rtl.arrayInsert(10, $mod.ArrJSValue, 11);',
- '$mod.ArrArrInt = rtl.arrayInsert([23], $mod.ArrArrInt, 22);',
- '$mod.ArrInt.splice(12, 13);',
- '$mod.ArrRec.splice(14, 15);',
- '$mod.ArrSet.splice(17, 18);',
- '$mod.ArrJSValue.splice(19, 10);',
- '']));
- end;
- procedure TTestModule.TestArray_DynArrayConstObjFPC;
- begin
- Parser.Options:=Parser.Options+[po_cassignments];
- StartProgram(false);
- Add([
- '{$modeswitch arrayoperators}',
- 'type',
- ' integer = longint;',
- ' TArrInt = array of integer;',
- ' TArrStr = array of string;',
- 'const',
- ' Ints: TArrInt = (1,2,3);',
- ' Aliases: TarrStr = (''foo'',''b'');',
- ' OneInt: TArrInt = (7);',
- ' OneStr: array of integer = (7);',
- ' Chars: array of char = ''aoc'';',
- ' Names: array of string = (''a'',''foo'');',
- ' NameCount = low(Names)+high(Names)+length(Names);',
- 'var i: integer;',
- 'begin',
- ' Ints:=[];',
- ' Ints:=[1,1];',
- ' Ints:=[1]+[2];',
- ' Ints:=[2];',
- ' Ints:=[]+ints;',
- ' Ints:=Ints+[];',
- ' Ints:=Ints+OneInt;',
- ' Ints:=Ints+[1,1];',
- ' Ints:=[i,i]+Ints;',
- ' Ints:=[1]+[i]+[3];',
- '']);
- ConvertProgram;
- CheckSource('TestArray_DynArrayConstObjFPC',
- LinesToStr([ // statements
- 'this.Ints = [1, 2, 3];',
- 'this.Aliases = ["foo", "b"];',
- 'this.OneInt = [7];',
- 'this.OneStr = [7];',
- 'this.Chars = ["a", "o", "c"];',
- 'this.Names = ["a", "foo"];',
- 'this.NameCount = 0 + (rtl.length(this.Names) - 1) + rtl.length(this.Names);',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Ints = [];',
- '$mod.Ints = [1, 1];',
- '$mod.Ints = rtl.arrayConcatN([1], [2]);',
- '$mod.Ints = [2];',
- '$mod.Ints = rtl.arrayConcatN([], $mod.Ints);',
- '$mod.Ints = rtl.arrayConcatN($mod.Ints, []);',
- '$mod.Ints = rtl.arrayConcatN($mod.Ints, $mod.OneInt);',
- '$mod.Ints = rtl.arrayConcatN($mod.Ints, [1, 1]);',
- '$mod.Ints = rtl.arrayConcatN([$mod.i, $mod.i], $mod.Ints);',
- '$mod.Ints = rtl.arrayConcatN(rtl.arrayConcatN([1], [$mod.i]), [3]);',
- '']));
- end;
- procedure TTestModule.TestArray_DynArrayConstDelphi;
- begin
- StartProgram(false);
- // Note: const c = [1,1]; defines a set!
- Add([
- '{$mode delphi}',
- 'type',
- ' integer = longint;',
- ' TArrInt = array of integer;',
- ' TArrStr = array of string;',
- 'const',
- ' Ints: TArrInt = [1,1,2];',
- ' Aliases: TarrStr = [''foo'',''b''];',
- ' OneInt: TArrInt = [7];',
- ' OneStr: array of integer = [7]+[8];',
- ' Chars: array of char = ''aoc'';',
- ' Names: array of string = [''a'',''a''];',
- ' NameCount = low(Names)+high(Names)+length(Names);',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestArray_DynArrayConstDelphi',
- LinesToStr([ // statements
- 'this.Ints = [1, 1, 2];',
- 'this.Aliases = ["foo", "b"];',
- 'this.OneInt = [7];',
- 'this.OneStr = rtl.arrayConcatN([7],[8]);',
- 'this.Chars = ["a", "o", "c"];',
- 'this.Names = ["a", "a"];',
- 'this.NameCount = 0 + (rtl.length(this.Names) - 1) + rtl.length(this.Names);',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestArray_ArrayLitAsParam;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch arrayoperators}',
- 'type',
- ' integer = longint;',
- ' TArrInt = array of integer;',
- ' TArrSet = array of (red,green,blue);',
- 'procedure DoOpenInt(const a: array of integer); forward;',
- 'procedure DoInt(const a: TArrInt);',
- 'begin',
- ' DoInt(a+[1]);',
- ' DoInt([1]+a);',
- ' DoOpenInt(a);',
- ' DoOpenInt(a+[1]);',
- ' DoOpenInt([1]+a);',
- 'end;',
- 'procedure DoOpenInt(const a: array of integer);',
- 'begin',
- ' DoOpenInt(a+[1]);',
- ' DoOpenInt([1]+a);',
- ' DoInt(a);',
- ' DoInt(a+[1]);',
- ' DoInt([1]+a);',
- 'end;',
- 'procedure DoSet(const a: TArrSet);',
- 'begin',
- ' DoSet(a+[red]);',
- ' DoSet([blue]+a);',
- 'end;',
- 'var',
- ' i: TArrInt;',
- ' s: TArrSet;',
- 'begin',
- ' DoInt([1]);',
- ' DoInt([1]+[2]);',
- ' DoInt(i+[1]);',
- ' DoInt([1]+i);',
- ' DoOpenInt([1]);',
- ' DoOpenInt([1]+[2]);',
- ' DoOpenInt(i+[1]);',
- ' DoOpenInt([1]+i);',
- ' DoSet([red]);',
- ' DoSet([blue]+[green]);',
- ' DoSet(s+[blue]);',
- ' DoSet([red]+s);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_ArrayLitAsParam',
- LinesToStr([ // statements
- 'this.TArrSet$a = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "green",',
- ' green: 1,',
- ' "2": "blue",',
- ' blue: 2',
- '};',
- 'this.DoInt = function (a) {',
- ' $mod.DoInt(rtl.arrayConcatN(a, [1]));',
- ' $mod.DoInt(rtl.arrayConcatN([1], a));',
- ' $mod.DoOpenInt(a);',
- ' $mod.DoOpenInt(rtl.arrayConcatN(a, [1]));',
- ' $mod.DoOpenInt(rtl.arrayConcatN([1], a));',
- '};',
- 'this.DoOpenInt = function (a) {',
- ' $mod.DoOpenInt(rtl.arrayConcatN(a, [1]));',
- ' $mod.DoOpenInt(rtl.arrayConcatN([1], a));',
- ' $mod.DoInt(a);',
- ' $mod.DoInt(rtl.arrayConcatN(a, [1]));',
- ' $mod.DoInt(rtl.arrayConcatN([1], a));',
- '};',
- 'this.DoSet = function (a) {',
- ' $mod.DoSet(rtl.arrayConcatN(a, [$mod.TArrSet$a.red]));',
- ' $mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.blue], a));',
- '};',
- 'this.i = [];',
- 'this.s = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoInt([1]);',
- '$mod.DoInt(rtl.arrayConcatN([1], [2]));',
- '$mod.DoInt(rtl.arrayConcatN($mod.i, [1]));',
- '$mod.DoInt(rtl.arrayConcatN([1], $mod.i));',
- '$mod.DoOpenInt([1]);',
- '$mod.DoOpenInt(rtl.arrayConcatN([1], [2]));',
- '$mod.DoOpenInt(rtl.arrayConcatN($mod.i, [1]));',
- '$mod.DoOpenInt(rtl.arrayConcatN([1], $mod.i));',
- '$mod.DoSet([$mod.TArrSet$a.red]);',
- '$mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.blue], [$mod.TArrSet$a.green]));',
- '$mod.DoSet(rtl.arrayConcatN($mod.s, [$mod.TArrSet$a.blue]));',
- '$mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.red], $mod.s));',
- '']));
- end;
- procedure TTestModule.TestArray_ArrayLitMultiDimAsParam;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch arrayoperators}',
- 'type',
- ' integer = longint;',
- ' TArrInt = array of integer;',
- ' TArrArrInt = array of TArrInt;',
- 'procedure DoInt(const a: TArrArrInt);',
- 'begin',
- ' DoInt(a+[[1]]);',
- ' DoInt([[1]]+a);',
- ' DoInt(a);',
- 'end;',
- 'var',
- ' i: TArrInt;',
- ' a: TArrArrInt;',
- 'begin',
- ' a:=[[1]];',
- ' a:=[i];',
- ' a:=a+[i];',
- ' a:=[i]+a;',
- ' a:=[[1]+i];',
- ' a:=[[1]+[2]];',
- ' a:=[i+[2]];',
- ' DoInt([[1]]);',
- ' DoInt([[1]+[2],[3,4],[5]]);',
- ' DoInt([i+[1]]+a);',
- ' DoInt([i]+a);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_ArrayLitMultiDimAsParam',
- LinesToStr([ // statements
- 'this.DoInt = function (a) {',
- ' $mod.DoInt(rtl.arrayConcatN(a, [[1]]));',
- ' $mod.DoInt(rtl.arrayConcatN([[1]], a));',
- ' $mod.DoInt(a);',
- '};',
- 'this.i = [];',
- 'this.a = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.a = [[1]];',
- '$mod.a = [$mod.i];',
- '$mod.a = rtl.arrayConcatN($mod.a, [$mod.i]);',
- '$mod.a = rtl.arrayConcatN([$mod.i], $mod.a);',
- '$mod.a = [rtl.arrayConcatN([1], $mod.i)];',
- '$mod.a = [rtl.arrayConcatN([1], [2])];',
- '$mod.a = [rtl.arrayConcatN($mod.i, [2])];',
- '$mod.DoInt([[1]]);',
- '$mod.DoInt([rtl.arrayConcatN([1], [2]), [3, 4], [5]]);',
- '$mod.DoInt(rtl.arrayConcatN([rtl.arrayConcatN($mod.i, [1])], $mod.a));',
- '$mod.DoInt(rtl.arrayConcatN([$mod.i], $mod.a));',
- '']));
- end;
- procedure TTestModule.TestArray_ArrayLitStaticAsParam;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch arrayoperators}',
- 'type',
- ' integer = longint;',
- ' TArrInt = array[1..2] of integer;',
- ' TArrArrInt = array of TArrInt;',
- 'procedure DoInt(const a: TArrArrInt);',
- 'begin',
- ' DoInt(a+[[1,2]]);',
- ' DoInt([[1,2]]+a);',
- ' DoInt(a);',
- 'end;',
- 'var',
- ' i: TArrInt;',
- ' a: TArrArrInt;',
- 'begin',
- ' a:=[[1,1]];',
- ' a:=[i];',
- ' a:=a+[i];',
- ' a:=[i]+a;',
- ' DoInt([[1,1]]);',
- ' DoInt([[1,2],[3,4]]);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_ArrayLitStaticAsParam',
- LinesToStr([ // statements
- 'this.DoInt = function (a) {',
- ' $mod.DoInt(rtl.arrayConcatN(a, [[1, 2]]));',
- ' $mod.DoInt(rtl.arrayConcatN([[1, 2]], a));',
- ' $mod.DoInt(a);',
- '};',
- 'this.i = rtl.arraySetLength(null, 0, 2);',
- 'this.a = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.a = [[1, 1]];',
- '$mod.a = [$mod.i.slice(0)];',
- '$mod.a = rtl.arrayConcatN($mod.a, [$mod.i.slice(0)]);',
- '$mod.a = rtl.arrayConcatN([$mod.i.slice(0)], $mod.a);',
- '$mod.DoInt([[1, 1]]);',
- '$mod.DoInt([[1, 2], [3, 4]]);',
- '']));
- end;
- procedure TTestModule.TestArray_ForInArrOfString;
- begin
- StartProgram(false);
- Add([
- 'type',
- 'type',
- ' TMonthNameArray = array [1..12] of string;',
- ' TMonthNames = TMonthNameArray;',
- ' TObject = class',
- ' private',
- ' function GetLongMonthNames: TMonthNames; virtual; abstract;',
- ' public',
- ' Property LongMonthNames : TMonthNames Read GetLongMonthNames;',
- ' end;',
- 'var',
- ' f: TObject;',
- ' Month: string;',
- ' Names: array of string = (''a'',''foo'',''bar'');',
- ' i: longint;',
- 'begin',
- ' for Month in f.LongMonthNames do ;',
- ' for Month in Names do ;',
- ' for i:=low(Names) to high(Names) do ;',
- '']);
- ConvertProgram;
- CheckSource('TestArray_ForInArrOfString',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.f = null;',
- 'this.Month = "";',
- 'this.Names = ["a", "foo", "bar"];',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- 'for (var $in = $mod.f.GetLongMonthNames(), $l = 0, $end = rtl.length($in) - 1; $l <= $end; $l++) $mod.Month = $in[$l];',
- 'for (var $in1 = $mod.Names, $l1 = 0, $end1 = rtl.length($in1) - 1; $l1 <= $end1; $l1++) $mod.Month = $in1[$l1];',
- 'for (var $l2 = 0, $end2 = rtl.length($mod.Names) - 1; $l2 <= $end2; $l2++) $mod.i = $l2;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastArrayToExternalClass;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSObject = class external name ''Object''',
- ' end;',
- ' TJSArray = class external name ''Array''',
- ' class function isArray(Value: JSValue) : boolean;',
- ' function concat() : TJSArray; varargs;',
- ' end;',
- 'var',
- ' aObj: TJSArray;',
- ' a: array of longint;',
- ' o: TJSObject;',
- 'begin',
- ' if TJSArray.isArray(65) then ;',
- ' aObj:=TJSArray(a).concat(a);',
- ' o:=TJSObject(a);']);
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastArrayToExternalClass',
- LinesToStr([ // statements
- 'this.aObj = null;',
- 'this.a = [];',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'if (Array.isArray(65)) ;',
- '$mod.aObj = $mod.a.concat($mod.a);',
- '$mod.o = $mod.a;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastArrayFromExternalClass;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TArrStr = array of string;',
- ' TJSArray = class external name ''Array''',
- ' end;',
- ' TJSObject = class external name ''Object''',
- ' end;',
- 'var',
- ' aObj: TJSArray;',
- ' a: TArrStr;',
- ' jo: TJSObject;',
- 'begin',
- ' a:=TArrStr(aObj);',
- ' TArrStr(aObj)[1]:=TArrStr(aObj)[2];',
- ' a:=TarrStr(jo);',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastArrayFromExternalClass',
- LinesToStr([ // statements
- 'this.aObj = null;',
- 'this.a = [];',
- 'this.jo = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.a = $mod.aObj;',
- '$mod.aObj[1] = $mod.aObj[2];',
- '$mod.a = $mod.jo;',
- '']));
- end;
- procedure TTestModule.TestArrayOfConst_TVarRec;
- begin
- StartProgram(true,[supTVarRec]);
- Add([
- 'procedure Say(args: array of const);',
- 'var',
- ' i: longint;',
- ' v: TVarRec;',
- 'begin',
- ' for i:=low(args) to high(args) do begin',
- ' v:=args[i];',
- ' case v.vtype of',
- ' vtInteger: if length(args)=args[i].vInteger then ;',
- ' end;',
- ' end;',
- ' for v in args do ;',
- ' args:=nil;',
- ' SetLength(args,2);',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestArrayOfConst_TVarRec',
- LinesToStr([ // statements
- 'this.Say = function (args) {',
- ' var i = 0;',
- ' var v = pas.system.TVarRec.$new();',
- ' for (var $l = 0, $end = rtl.length(args) - 1; $l <= $end; $l++) {',
- ' i = $l;',
- ' v.$assign(args[i]);',
- ' var $tmp = v.VType;',
- ' if ($tmp === 0) if (rtl.length(args) === args[i].VJSValue) ;',
- ' };',
- ' for (var $in = args, $l1 = 0, $end1 = rtl.length($in) - 1; $l1 <= $end1; $l1++) v = $in[$l1];',
- ' args = [];',
- ' args = rtl.arraySetLength(args, pas.system.TVarRec, 2);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- ]));
- end;
- procedure TTestModule.TestArrayOfConst_PassBaseTypes;
- begin
- StartProgram(true,[supTVarRec]);
- Add([
- 'procedure Say(args: array of const);',
- 'begin',
- ' Say(args);',
- 'end;',
- 'var',
- ' p: Pointer;',
- ' j: jsvalue;',
- ' c: currency;',
- 'begin',
- ' Say([]);',
- ' Say([1]);',
- ' Say([''c'',''foo'',nil,true,1.3,p,j,c]);',
- '']);
- ConvertProgram;
- CheckSource('TestArrayOfConst_PassBaseTypes',
- LinesToStr([ // statements
- 'this.Say = function (args) {',
- ' $mod.Say(args);',
- '};',
- 'this.p = null;',
- 'this.j = undefined;',
- 'this.c = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Say([]);',
- '$mod.Say(pas.system.VarRecs(0, 1));',
- '$mod.Say(pas.system.VarRecs(',
- ' 9,',
- ' "c",',
- ' 18,',
- ' "foo",',
- ' 5,',
- ' null,',
- ' 1,',
- ' true,',
- ' 3,',
- ' 1.3,',
- ' 5,',
- ' $mod.p,',
- ' 20,',
- ' $mod.j,',
- ' 12,',
- ' $mod.c',
- ' ));',
- '']));
- end;
- procedure TTestModule.TestArrayOfConst_PassObj;
- begin
- StartProgram(true,[supTVarRec]);
- Add([
- '{$interfaces corba}',
- 'type',
- ' TObject = class',
- ' end;',
- ' TClass = class of TObject;',
- ' IUnknown = interface',
- ' end;',
- 'procedure Say(args: array of const);',
- 'begin',
- 'end;',
- 'var',
- ' o: TObject;',
- ' c: TClass;',
- ' i: IUnknown;',
- 'begin',
- ' Say([o,c,TObject]);',
- ' Say([nil,i]);',
- '']);
- ConvertProgram;
- CheckSource('TestArrayOfConst_PassObj',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'this.Say = function (args) {',
- '};',
- 'this.o = null;',
- 'this.c = null;',
- 'this.i = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Say(pas.system.VarRecs(',
- ' 7,',
- ' $mod.o,',
- ' 8,',
- ' $mod.c,',
- ' 8,',
- ' $mod.TObject',
- '));',
- '$mod.Say(pas.system.VarRecs(5, null, 14, $mod.i));',
- '']));
- end;
- procedure TTestModule.TestRecord_Empty;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TRecA = record',
- ' end;',
- 'var a,b: TRecA;',
- 'begin',
- ' if a=b then ;']);
- ConvertProgram;
- CheckSource('TestRecord_Empty',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRecA", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- '});',
- 'this.a = this.TRecA.$new();',
- 'this.b = this.TRecA.$new();',
- '']),
- LinesToStr([ // $mod.$main
- 'if ($mod.a.$eq($mod.b)) ;'
- ]));
- end;
- procedure TTestModule.TestRecord_Var;
- begin
- StartProgram(false);
- Add('type');
- Add(' TRecA = record');
- Add(' Bold: longint;');
- Add(' end;');
- Add('var Rec: TRecA;');
- Add('begin');
- Add(' rec.bold:=123');
- ConvertProgram;
- CheckSource('TestRecord_Var',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRecA", function () {',
- ' this.Bold = 0;',
- ' this.$eq = function (b) {',
- ' return this.Bold === b.Bold;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Bold = s.Bold;',
- ' return this;',
- ' };',
- '});',
- 'this.Rec = this.TRecA.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Rec.Bold = 123;'
- ]));
- end;
- procedure TTestModule.TestRecord_VarExternal;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TRecA = record',
- ' i: byte;',
- ' length_: longint external name ''length'';',
- ' end;',
- 'var Rec: TRecA;',
- 'begin',
- ' rec.length_ := rec.length_',
- '']);
- ConvertProgram;
- CheckSource('TestRecord_VarExternal',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRecA", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return (this.i === b.i) && (this.length === b.length);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' this.length = s.length;',
- ' return this;',
- ' };',
- '});',
- 'this.Rec = this.TRecA.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Rec.length = $mod.Rec.length;'
- ]));
- end;
- procedure TTestModule.TestRecord_WithDo;
- begin
- StartProgram(false);
- Add('type');
- Add(' TRec = record');
- Add(' vI: longint;');
- Add(' end;');
- Add('var');
- Add(' Int: longint;');
- Add(' r: TRec;');
- Add('begin');
- Add(' with r do');
- Add(' int:=vi;');
- Add(' with r do begin');
- Add(' int:=vi;');
- Add(' vi:=int;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestWithRecordDo',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.vI = 0;',
- ' this.$eq = function (b) {',
- ' return this.vI === b.vI;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.vI = s.vI;',
- ' return this;',
- ' };',
- '});',
- 'this.Int = 0;',
- 'this.r = this.TRec.$new();',
- '']),
- LinesToStr([ // $mod.$main
- 'var $with = $mod.r;',
- '$mod.Int = $with.vI;',
- 'var $with1 = $mod.r;',
- '$mod.Int = $with1.vI;',
- '$with1.vI = $mod.Int;'
- ]));
- end;
- procedure TTestModule.TestRecord_Assign;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (red,green);',
- ' TEnums = set of TEnum;',
- ' TSmallRec = record',
- ' N: longint;',
- ' end;',
- ' TBigRec = record',
- ' Int: longint;',
- ' D: double;',
- ' Arr: array of longint;',
- ' Arr2: array[1..2] of longint;',
- ' Small: TSmallRec;',
- ' Enums: TEnums;',
- ' end;',
- 'var',
- ' r, s: TBigRec;',
- 'begin',
- ' r:=s;',
- ' r:=default(TBigRec);',
- ' r:=default(s);',
- '']);
- ConvertProgram;
- CheckSource('TestRecord_Assign',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "green",',
- ' green: 1',
- '};',
- 'rtl.recNewT(this, "TSmallRec", function () {',
- ' this.N = 0;',
- ' this.$eq = function (b) {',
- ' return this.N === b.N;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.N = s.N;',
- ' return this;',
- ' };',
- '});',
- 'rtl.recNewT(this, "TBigRec", function () {',
- ' this.Int = 0;',
- ' this.D = 0.0;',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.Arr = [];',
- ' r.Arr2 = rtl.arraySetLength(null, 0, 2);',
- ' r.Small = $mod.TSmallRec.$new();',
- ' r.Enums = {};',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.Int === b.Int) && (this.D === b.D) && (this.Arr === b.Arr) && rtl.arrayEq(this.Arr2, b.Arr2) && this.Small.$eq(b.Small) && rtl.eqSet(this.Enums, b.Enums);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Int = s.Int;',
- ' this.D = s.D;',
- ' this.Arr = rtl.arrayRef(s.Arr);',
- ' this.Arr2 = s.Arr2.slice(0);',
- ' this.Small.$assign(s.Small);',
- ' this.Enums = rtl.refSet(s.Enums);',
- ' return this;',
- ' };',
- '});',
- 'this.r = this.TBigRec.$new();',
- 'this.s = this.TBigRec.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.r.$assign($mod.s);',
- '$mod.r.$assign($mod.TBigRec.$new());',
- '$mod.r.$assign($mod.TBigRec.$new());',
- '']));
- end;
- procedure TTestModule.TestRecord_AsParams;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' TRecord = record',
- ' i: integer;',
- ' end;',
- 'procedure DoIt(vD: TRecord; const vC: TRecord; var vV: TRecord; var U);',
- 'var vL: TRecord;',
- 'begin',
- ' vd:=vd;',
- ' vd.i:=vd.i;',
- ' vl:=vc;',
- ' vv:=vv;',
- ' vv.i:=vv.i;',
- ' U:=vl;',
- ' U:=vd;',
- ' U:=vc;',
- ' U:=vv;',
- ' vl:=TRecord(U);',
- ' vd:=TRecord(U);',
- ' vv:=TRecord(U);',
- ' doit(vd,vd,vd,vd);',
- ' doit(vc,vc,vl,vl);',
- ' doit(vv,vv,vv,vv);',
- ' doit(vl,vl,vl,vl);',
- ' TRecord(U).i:=3;',
- 'end;',
- 'var i: TRecord;',
- 'begin',
- ' doit(i,i,i,i);',
- '']);
- ConvertProgram;
- CheckSource('TestRecord_AsParams',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRecord", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.DoIt = function (vD, vC, vV, U) {',
- ' var vL = $mod.TRecord.$new();',
- ' vD.$assign(vD);',
- ' vD.i = vD.i;',
- ' vL.$assign(vC);',
- ' vV.$assign(vV);',
- ' vV.i = vV.i;',
- ' U.$assign(vL);',
- ' U.$assign(vD);',
- ' U.$assign(vC);',
- ' U.$assign(vV);',
- ' vL.$assign(U);',
- ' vD.$assign(U);',
- ' vV.$assign(U);',
- ' $mod.DoIt($mod.TRecord.$clone(vD), vD, vD, vD);',
- ' $mod.DoIt($mod.TRecord.$clone(vC), vC, vL, vL);',
- ' $mod.DoIt($mod.TRecord.$clone(vV), vV, vV, vV);',
- ' $mod.DoIt($mod.TRecord.$clone(vL), vL, vL, vL);',
- ' U.i = 3;',
- '};',
- 'this.i = this.TRecord.$new();'
- ]),
- LinesToStr([
- '$mod.DoIt($mod.TRecord.$clone($mod.i), $mod.i, $mod.i, $mod.i);',
- '']));
- end;
- procedure TTestModule.TestRecord_ConstRef;
- begin
- StartProgram(false);
- Add([
- 'type TRec = record i: word; end;',
- 'procedure Run(constref a: TRec);',
- 'begin',
- 'end;',
- 'procedure Fly(a: TRec; var b: TRec; out c: TRec; const d: TRec; constref e: TRec);',
- 'var l: TRec;',
- 'begin',
- ' Run(l);',
- ' Run(a);',
- ' Run(b);',
- ' Run(c);',
- ' Run(d);',
- ' Run(e);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckResolverUnexpectedHints();
- CheckSource('TestRecord_ConstRef',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.Run = function (a) {',
- '};',
- 'this.Fly = function (a, b, c, d, e) {',
- ' var l = $mod.TRec.$new();',
- ' $mod.Run(l);',
- ' $mod.Run(a);',
- ' $mod.Run(b);',
- ' $mod.Run(c);',
- ' $mod.Run(d);',
- ' $mod.Run(e);',
- '};',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestRecordElement_AsParams;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TRecord = record');
- Add(' i: integer;');
- Add(' end;');
- Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
- Add('var vJ: TRecord;');
- Add('begin');
- Add(' doit(vj.i,vj.i,vj.i);');
- Add('end;');
- Add('var r: TRecord;');
- Add('begin');
- Add(' doit(r.i,r.i,r.i);');
- ConvertProgram;
- CheckSource('TestRecordElement_AsParams',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRecord", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = $mod.TRecord.$new();',
- ' $mod.DoIt(vJ.i, vJ.i, {',
- ' p: vJ,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- ' });',
- '};',
- 'this.r = this.TRecord.$new();'
- ]),
- LinesToStr([
- '$mod.DoIt($mod.r.i,$mod.r.i,{',
- ' p: $mod.r,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});'
- ]));
- end;
- procedure TTestModule.TestRecordElementFromFuncResult_AsParams;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TRecord = record');
- Add(' i: integer;');
- Add(' end;');
- Add('function GetRec(vB: integer = 0): TRecord;');
- Add('begin');
- Add('end;');
- Add('procedure DoIt(vG: integer; const vH: integer);');
- Add('begin');
- Add('end;');
- Add('begin');
- Add(' doit(getrec.i,getrec.i);');
- Add(' doit(getrec().i,getrec().i);');
- Add(' doit(getrec(1).i,getrec(2).i);');
- ConvertProgram;
- CheckSource('TestRecordElementFromFuncResult_AsParams',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRecord", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.GetRec = function (vB) {',
- ' var Result = $mod.TRecord.$new();',
- ' return Result;',
- '};',
- 'this.DoIt = function (vG, vH) {',
- '};',
- '']),
- LinesToStr([
- '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
- '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
- '$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i);',
- '']));
- end;
- procedure TTestModule.TestRecordElementFromWith_AsParams;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TRecord = record');
- Add(' i: integer;');
- Add(' end;');
- Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
- Add('begin');
- Add('end;');
- Add('var r: trecord;');
- Add('begin');
- Add(' with r do ');
- Add(' doit(i,i,i);');
- ConvertProgram;
- CheckSource('TestRecordElementFromWith_AsParams',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRecord", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.DoIt = function (vG,vH,vI) {',
- '};',
- 'this.r = this.TRecord.$new();'
- ]),
- LinesToStr([
- 'var $with = $mod.r;',
- '$mod.DoIt($with.i,$with.i,{',
- ' p: $with,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});',
- '']));
- end;
- procedure TTestModule.TestRecord_Equal;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TFlag = (red,blue);');
- Add(' TFlags = set of TFlag;');
- Add(' TProc = procedure;');
- Add(' TRecord = record');
- Add(' i: integer;');
- Add(' Event: TProc;');
- Add(' f: TFlags;');
- Add(' end;');
- Add(' TNested = record');
- Add(' r: TRecord;');
- Add(' end;');
- Add('var');
- Add(' b: boolean;');
- Add(' r,s: trecord;');
- Add('begin');
- Add(' b:=r=s;');
- Add(' b:=r<>s;');
- ConvertProgram;
- CheckSource('TestRecord_Equal',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'rtl.recNewT(this, "TRecord", function () {',
- ' this.i = 0;',
- ' this.Event = null;',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.f = {};',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.i === b.i) && rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' this.Event = s.Event;',
- ' this.f = rtl.refSet(s.f);',
- ' return this;',
- ' };',
- '});',
- 'rtl.recNewT(this, "TNested", function () {',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.r = $mod.TRecord.$new();',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return this.r.$eq(b.r);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.r.$assign(s.r);',
- ' return this;',
- ' };',
- '});',
- 'this.b = false;',
- 'this.r = this.TRecord.$new();',
- 'this.s = this.TRecord.$new();',
- '']),
- LinesToStr([
- '$mod.b = $mod.r.$eq($mod.s);',
- '$mod.b = !$mod.r.$eq($mod.s);',
- '']));
- end;
- procedure TTestModule.TestRecord_JSValue;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TRecord = record',
- ' i: longint;',
- ' end;',
- 'procedure Fly(d: jsvalue; const c: jsvalue);',
- 'begin',
- 'end;',
- 'procedure Run(d: TRecord; const c: TRecord; var v: TRecord);',
- 'begin',
- ' if jsvalue(d) then ;',
- ' if jsvalue(c) then ;',
- ' if jsvalue(v) then ;',
- 'end;',
- 'var',
- ' Jv: jsvalue;',
- ' Rec: trecord;',
- 'begin',
- ' rec:=trecord(jv);',
- ' jv:=rec;',
- ' Fly(rec,rec);',
- ' Fly(@rec,@rec);',
- ' if jsvalue(Rec) then ;',
- ' Run(trecord(jv),trecord(jv),rec);',
- '']);
- ConvertProgram;
- CheckSource('TestRecord_JSValue',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRecord", function () {',
- ' this.i = 0;',
- ' this.$eq = function (b) {',
- ' return this.i === b.i;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' return this;',
- ' };',
- '});',
- 'this.Fly = function (d, c) {',
- '};',
- 'this.Run = function (d, c, v) {',
- ' if (d) ;',
- ' if (c) ;',
- ' if (v) ;',
- '};',
- 'this.Jv = undefined;',
- 'this.Rec = this.TRecord.$new();',
- '']),
- LinesToStr([
- '$mod.Rec.$assign(rtl.getObject($mod.Jv));',
- '$mod.Jv = $mod.Rec;',
- '$mod.Fly($mod.TRecord.$clone($mod.Rec), $mod.Rec);',
- '$mod.Fly($mod.Rec, $mod.Rec);',
- 'if ($mod.Rec) ;',
- '$mod.Run($mod.TRecord.$clone(rtl.getObject($mod.Jv)), rtl.getObject($mod.Jv), $mod.Rec);',
- '']));
- end;
- procedure TTestModule.TestRecord_VariantFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TRec = record',
- ' case word of',
- ' 0: (b0, b1: Byte);',
- ' 1: (i: word);',
- ' end;',
- 'begin']);
- SetExpectedPasResolverError('variant record is not supported',
- nXIsNotSupported);
- ConvertProgram;
- end;
- procedure TTestModule.TestRecord_FieldArray;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrInt = array[3..4] of longint;',
- ' TArrArrInt = array[3..4] of longint;',
- ' TRec = record',
- ' a: array of longint;',
- ' s: array[1..2] of longint;',
- ' m: array[1..2,3..4] of longint;',
- ' o: TArrArrInt;',
- ' end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRecord_FieldArray',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.a = [];',
- ' r.s = rtl.arraySetLength(null, 0, 2);',
- ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
- ' r.o = rtl.arraySetLength(null, 0, 2);',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && rtl.arrayEq(this.o, b.o);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.a = rtl.arrayRef(s.a);',
- ' this.s = s.s.slice(0);',
- ' this.m = s.m.slice(0);',
- ' this.o = s.o.slice(0);',
- ' return this;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRecord_Const;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrInt = array[3..4] of longint;',
- ' TPoint = record x,y: longint; end;',
- ' TRec = record',
- ' i: longint;',
- ' a: array of longint;',
- ' s: array[1..2] of longint;',
- ' m: array[1..2,3..4] of longint;',
- ' p: TPoint;',
- ' end;',
- ' TPoints = array of TPoint;',
- 'const',
- ' r: TRec = (',
- ' i:1;',
- ' a:(2,3);',
- ' s:(4,5);',
- ' m:( (11,12), (13,14) );',
- ' p: (x:21; y:22)',
- ' );',
- ' p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRecord_Const',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- '});',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.i = 0;',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.a = [];',
- ' r.s = rtl.arraySetLength(null, 0, 2);',
- ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
- ' r.p = $mod.TPoint.$new();',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.i === b.i) && (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && this.p.$eq(b.p);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' this.a = rtl.arrayRef(s.a);',
- ' this.s = s.s.slice(0);',
- ' this.m = s.m.slice(0);',
- ' this.p.$assign(s.p);',
- ' return this;',
- ' };',
- '});',
- 'this.r = this.TRec.$clone({',
- ' i: 1,',
- ' a: [2, 3],',
- ' s: [4, 5],',
- ' m: [[11, 12], [13, 14]],',
- ' p: this.TPoint.$clone({',
- ' x: 21,',
- ' y: 22',
- ' })',
- '});',
- 'this.p = [this.TPoint.$clone({',
- ' x: 1,',
- ' y: 2',
- '}), this.TPoint.$clone({',
- ' x: 3,',
- ' y: 4',
- '})];',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRecord_TypecastFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TPoint = record x,y: longint; end;',
- ' TRec = record l: longint end;',
- 'var p: TPoint;',
- 'begin',
- ' if TRec(p).l=2 then ;']);
- SetExpectedPasResolverError('Illegal type conversion: "TPoint" to "record TRec"',
- nIllegalTypeConversionTo);
- ConvertProgram;
- end;
- procedure TTestModule.TestRecord_InFunction;
- begin
- StartProgram(false);
- Add([
- 'var TPoint: longint = 3;',
- 'procedure DoIt;',
- 'type',
- ' TPoint = record x,y: longint; end;',
- ' TPoints = array of TPoint;',
- 'var',
- ' r: TPoint;',
- ' p: TPoints;',
- 'begin',
- ' SetLength(p,2);',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRecord_InFunction',
- LinesToStr([ // statements
- 'this.TPoint = 3;',
- 'var TPoint$1 = rtl.recNewT(null, "", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- '});',
- 'this.DoIt = function () {',
- ' var r = TPoint$1.$new();',
- ' var p = [];',
- ' p = rtl.arraySetLength(p, TPoint$1, 2);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRecord_AnonymousFail;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' r: record x: word end;',
- 'begin']);
- SetExpectedPasResolverError('not yet implemented: :TPasRecordType [20190408224556] "anonymous record type"',
- nNotYetImplemented);
- ConvertProgram;
- end;
- procedure TTestModule.TestAdvRecord_Function;
- begin
- StartProgram(false);
- Parser.Options:=Parser.Options+[po_cassignments];
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TPoint = record',
- ' x,y: word;',
- ' function Add(const apt: TPoint): TPoint;',
- ' end;',
- 'function TPoint.Add(const apt: TPoint): TPoint;',
- 'begin',
- ' Result:=Self;',
- ' Result.x+=apt.x;',
- ' Result.y:=Result.y+apt.y;',
- ' Self:=apt;',
- 'end;',
- 'var p,q: TPoint;',
- 'begin',
- ' p.add(q);',
- ' p:=default(TPoint);',
- ' p:=q;',
- '']);
- ConvertProgram;
- CheckSource('TestAdvRecord_Function',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- ' this.Add = function (apt) {',
- ' var Result = $mod.TPoint.$new();',
- ' Result.$assign(this);',
- ' Result.x += apt.x;',
- ' Result.y = Result.y + apt.y;',
- ' this.$assign(apt);',
- ' return Result;',
- ' };',
- '});',
- 'this.p = this.TPoint.$new();',
- 'this.q = this.TPoint.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p.Add($mod.q);',
- '$mod.p.$assign($mod.TPoint.$new());',
- '$mod.p.$assign($mod.q);',
- '']));
- end;
- procedure TTestModule.TestAdvRecord_Property;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TPoint = record',
- ' x,y: word;',
- ' strict private',
- ' function GetSize: longword;',
- ' procedure SetSize(Value: longword);',
- ' public',
- ' property Size: longword read GetSize write SetSize;',
- ' property Left: word read x write y;',
- ' end;',
- 'procedure SetSize(Value: longword); begin end;',// check auto rename
- 'function TPoint.GetSize: longword;',
- 'begin',
- ' x:=y;',
- ' Size:=Size;',
- ' Left:=Left;',
- 'end;',
- 'procedure TPoint.SetSize(Value: longword);',
- 'begin',
- 'end;',
- 'var p,q: TPoint;',
- 'begin',
- ' p.Size:=q.Size;',
- ' p.Left:=q.Left;',
- '']);
- ConvertProgram;
- CheckSource('TestAdvRecord_Property',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- ' this.GetSize = function () {',
- ' var Result = 0;',
- ' this.x = this.y;',
- ' this.SetSize(this.GetSize());',
- ' this.y = this.x;',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Value) {',
- ' };',
- '});',
- 'this.SetSize = function (Value) {',
- '};',
- 'this.p = this.TPoint.$new();',
- 'this.q = this.TPoint.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p.SetSize($mod.q.GetSize());',
- '$mod.p.y = $mod.q.x;',
- '']));
- end;
- procedure TTestModule.TestAdvRecord_PropertyDefault;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TPoint = record',
- ' strict private',
- ' function GetItems(Index: word): word;',
- ' procedure SetItems(Index: word; Value: word);',
- ' public',
- ' property Items[Index: word]: word read GetItems write SetItems; default;',
- ' end;',
- 'function TPoint.GetItems(Index: word): word;',
- 'begin',
- ' Items[index]:=Items[index];',
- ' self.Items[index]:=self.Items[index];',
- 'end;',
- 'procedure TPoint.SetItems(Index: word; Value: word);',
- 'begin',
- 'end;',
- 'var p: TPoint;',
- 'begin',
- ' p[1]:=p[2];',
- ' p.Items[3]:=p.Items[4];',
- '']);
- ConvertProgram;
- CheckSource('TestAdvRecord_PropertyDefault',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' this.GetItems = function (Index) {',
- ' var Result = 0;',
- ' this.SetItems(Index, this.GetItems(Index));',
- ' this.SetItems(Index, this.GetItems(Index));',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' };',
- '});',
- 'this.p = this.TPoint.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p.SetItems(1, $mod.p.GetItems(2));',
- '$mod.p.SetItems(3, $mod.p.GetItems(4));',
- '']));
- end;
- procedure TTestModule.TestAdvRecord_Property_ClassMethod;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TRec = record',
- ' class var',
- ' Fx: longint;',
- ' Fy: longint;',
- ' class function GetInt: longint; static;',
- ' class procedure SetInt(Value: longint); static;',
- ' class procedure DoIt; static;',
- ' class property IntA: longint read Fx write Fy;',
- ' class property IntB: longint read GetInt write SetInt;',
- ' end;',
- 'class function trec.getint: longint;',
- 'begin',
- ' result:=fx;',
- 'end;',
- 'class procedure trec.setint(value: longint);',
- 'begin',
- 'end;',
- 'class procedure trec.doit;',
- 'begin',
- ' IntA:=IntA+1;',
- ' IntB:=IntB+1;',
- 'end;',
- 'var r: trec;',
- 'begin',
- ' trec.inta:=trec.inta+1;',
- ' if trec.intb=2 then;',
- ' trec.intb:=trec.intb+2;',
- ' trec.setint(trec.inta);',
- ' r.inta:=r.inta+1;',
- ' if r.intb=2 then;',
- ' r.intb:=r.intb+2;',
- ' r.setint(r.inta);']);
- ConvertProgram;
- CheckSource('TestAdvRecord_Property_ClassMethod',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.Fx = 0;',
- ' this.Fy = 0;',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' this.GetInt = function () {',
- ' var Result = 0;',
- ' Result = $mod.TRec.Fx;',
- ' return Result;',
- ' };',
- ' this.SetInt = function (Value) {',
- ' };',
- ' this.DoIt = function () {',
- ' $mod.TRec.Fy = $mod.TRec.Fx + 1;',
- ' $mod.TRec.SetInt($mod.TRec.GetInt() + 1);',
- ' };',
- '}, true);',
- 'this.r = this.TRec.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TRec.Fy = $mod.TRec.Fx + 1;',
- 'if ($mod.TRec.GetInt() === 2) ;',
- '$mod.TRec.SetInt($mod.TRec.GetInt() + 2);',
- '$mod.TRec.SetInt($mod.TRec.Fx);',
- '$mod.TRec.Fy = $mod.r.Fx + 1;',
- 'if ($mod.TRec.GetInt() === 2) ;',
- '$mod.TRec.SetInt($mod.TRec.GetInt() + 2);',
- '$mod.TRec.SetInt($mod.r.Fx);',
- '']));
- end;
- procedure TTestModule.TestAdvRecord_Const;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TArrInt = array[3..4] of longint;',
- ' TPoint = record',
- ' x,y: longint;',
- ' class var Count: nativeint;',
- ' end;',
- ' TRec = record',
- ' i: longint;',
- ' a: array of longint;',
- ' s: array[1..2] of longint;',
- ' m: array[1..2,3..4] of longint;',
- ' p: TPoint;',
- ' end;',
- ' TPoints = array of TPoint;',
- 'const',
- ' r: TRec = (',
- ' i:1;',
- ' a:(2,3);',
- ' s:(4,5);',
- ' m:( (11,12), (13,14) );',
- ' p: (x:21)',
- ' );',
- ' p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
- 'begin']);
- ConvertProgram;
- CheckSource('TestAdvRecord_Const',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.Count = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- '}, true);',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.i = 0;',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.a = [];',
- ' r.s = rtl.arraySetLength(null, 0, 2);',
- ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
- ' r.p = $mod.TPoint.$new();',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.i === b.i) && (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && this.p.$eq(b.p);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' this.a = rtl.arrayRef(s.a);',
- ' this.s = s.s.slice(0);',
- ' this.m = s.m.slice(0);',
- ' this.p.$assign(s.p);',
- ' return this;',
- ' };',
- '});',
- 'this.r = this.TRec.$clone({',
- ' i: 1,',
- ' a: [2, 3],',
- ' s: [4, 5],',
- ' m: [[11, 12], [13, 14]],',
- ' p: this.TPoint.$clone({',
- ' x: 21,',
- ' y: 0',
- ' })',
- '});',
- 'this.p = [this.TPoint.$clone({',
- ' x: 1,',
- ' y: 2',
- '}), this.TPoint.$clone({',
- ' x: 3,',
- ' y: 4',
- '})];',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestAdvRecord_ExternalField;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- '{$modeswitch externalclass}',
- 'type',
- ' TCar = record',
- ' public',
- ' Intern: longint external name ''$Intern'';',
- ' Intern2: longint external name ''$Intern2'';',
- ' Bracket: longint external name ''["A B"]'';',
- ' procedure DoIt;',
- ' end;',
- 'procedure tcar.doit;',
- 'begin',
- ' Intern:=Intern+1;',
- ' Intern2:=Intern2+2;',
- ' Bracket:=Bracket+3;',
- 'end;',
- 'var Rec: TCar = (intern: 11; intern2: 12; bracket: 13);',
- 'begin',
- ' Rec.intern:=Rec.intern+1;',
- ' Rec.intern2:=Rec.intern2+2;',
- ' Rec.Bracket:=Rec.Bracket+3;',
- ' with Rec do begin',
- ' intern:=intern+1;',
- ' intern2:=intern2+2;',
- ' Bracket:=Bracket+3;',
- ' end;']);
- ConvertProgram;
- CheckSource('TestAdvRecord_ExternalField',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TCar", function () {',
- ' this.$eq = function (b) {',
- ' return (this.$Intern === b.$Intern) && (this.$Intern2 === b.$Intern2) && (this["A B"] === b["A B"]);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.$Intern = s.$Intern;',
- ' this.$Intern2 = s.$Intern2;',
- ' this["A B"] = s["A B"];',
- ' return this;',
- ' };',
- ' this.DoIt = function () {',
- ' this.$Intern = this.$Intern + 1;',
- ' this.$Intern2 = this.$Intern2 + 2;',
- ' this["A B"] = this["A B"] + 3;',
- ' };',
- '});',
- 'this.Rec = this.TCar.$clone({',
- ' $Intern: 11,',
- ' $Intern2: 12,',
- ' "A B": 13',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Rec.$Intern = $mod.Rec.$Intern + 1;',
- '$mod.Rec.$Intern2 = $mod.Rec.$Intern2 + 2;',
- '$mod.Rec["A B"] = $mod.Rec["A B"] + 3;',
- 'var $with = $mod.Rec;',
- '$with.$Intern = $with.$Intern + 1;',
- '$with.$Intern2 = $with.$Intern2 + 2;',
- '$with["A B"] = $with["A B"] + 3;',
- '']));
- end;
- procedure TTestModule.TestAdvRecord_SubRecord;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TRec = record',
- ' type',
- ' TPoint = record',
- ' x,y: longint;',
- ' class var Count: nativeint;',
- ' procedure DoIt;',
- ' class procedure DoThat; static;',
- ' end;',
- ' var',
- ' i: longint;',
- ' p: TPoint;',
- ' procedure DoSome;',
- ' end;',
- 'const',
- ' r: TRec = (',
- ' i:1;',
- ' p: (x:21;y:22)',
- ' );',
- 'procedure TRec.DoSome;',
- 'begin',
- ' p.x:=p.y+1;',
- ' p.Count:=p.Count+2;',
- 'end;',
- 'procedure TRec.TPoint.DoIt;',
- 'begin',
- ' Count:=Count+3;',
- 'end;',
- 'class procedure TRec.TPoint.DoThat;',
- 'begin',
- ' Count:=Count+4;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestAdvRecord_SubRecord',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.Count = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- ' this.DoIt = function () {',
- ' $mod.TRec.TPoint.Count = this.Count + 3;',
- ' };',
- ' this.DoThat = function () {',
- ' $mod.TRec.TPoint.Count = $mod.TRec.TPoint.Count + 4;',
- ' };',
- ' }, true);',
- ' this.i = 0;',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.p = this.TPoint.$new();',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.i === b.i) && this.p.$eq(b.p);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.i = s.i;',
- ' this.p.$assign(s.p);',
- ' return this;',
- ' };',
- ' this.DoSome = function () {',
- ' this.p.x = this.p.y + 1;',
- ' this.TPoint.Count = this.p.Count + 2;',
- ' };',
- '}, true);',
- 'this.r = this.TRec.$clone({',
- ' i: 1,',
- ' p: this.TRec.TPoint.$clone({',
- ' x: 21,',
- ' y: 22',
- ' })',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestAdvRecord_SubClass;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TObject = class end;',
- ' TPoint = record',
- ' type',
- ' TBird = class',
- ' procedure DoIt;',
- ' class procedure Glob;',
- ' end;',
- ' procedure DoIt(b: TBird);',
- ' end;',
- 'procedure TPoint.TBird.DoIt;',
- 'begin',
- ' doit;',
- ' self.doit;',
- ' glob;',
- ' self.glob;',
- 'end;',
- 'class procedure TPoint.TBird.Glob;',
- 'begin',
- ' glob;',
- ' self.glob;',
- 'end;',
- 'procedure TPoint.DoIt(b: TBird);',
- 'begin',
- ' b.doit;',
- ' b.glob;',
- ' TBird.glob;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestAdvRecord_SubClass',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.recNewT(this, "TPoint", function () {',
- ' rtl.createClass(this, "TBird", $mod.TObject, function () {',
- ' this.DoIt = function () {',
- ' this.DoIt();',
- ' this.DoIt();',
- ' this.$class.Glob();',
- ' this.$class.Glob();',
- ' };',
- ' this.Glob = function () {',
- ' this.Glob();',
- ' this.Glob();',
- ' };',
- ' }, "TPoint.TBird");',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' this.DoIt = function (b) {',
- ' b.DoIt();',
- ' b.$class.Glob();',
- ' this.TBird.Glob();',
- ' };',
- '}, true);',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestAdvRecord_SubInterfaceFail;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' IUnknown = interface end;',
- ' TPoint = record',
- ' type IBird = interface end;',
- ' end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('not yet implemented: IBird:TPasClassType [20190105143752] "interface inside record"',
- nNotYetImplemented);
- ParseProgram;
- end;
- procedure TTestModule.TestAdvRecord_Constructor;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TPoint = record',
- ' x,y: longint;',
- ' class procedure Run(w: longint = 13); static;',
- ' constructor Create(ax: longint; ay: longint = -1);',
- ' end;',
- 'class procedure tpoint.run(w: longint);',
- 'begin',
- ' run;',
- ' run();',
- 'end;',
- 'constructor tpoint.create(ax,ay: longint);',
- 'begin',
- ' x:=ax;',
- ' self.y:=ay;',
- ' run;',
- ' run(ax);',
- 'end;',
- 'var r: TPoint;',
- 'begin',
- ' r:=TPoint.Create(1,2);',
- ' with TPoint do r:=Create(1,2);',
- ' r.Create(3);',
- ' r:=r.Create(4);',
- '']);
- ConvertProgram;
- CheckSource('TestAdvRecord_Constructor',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- ' this.Run = function (w) {',
- ' $mod.TPoint.Run(13);',
- ' $mod.TPoint.Run(13);',
- ' };',
- ' this.Create = function (ax, ay) {',
- ' this.x = ax;',
- ' this.y = ay;',
- ' this.Run(13);',
- ' this.Run(ax);',
- ' return this;',
- ' };',
- '});',
- 'this.r = this.TPoint.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.r.$assign($mod.TPoint.$new().Create(1, 2));',
- 'var $with = $mod.TPoint;',
- '$mod.r.$assign($with.$new().Create(1, 2));',
- '$mod.r.Create(3, -1);',
- '$mod.r.$assign($mod.r.Create(4, -1));',
- '']));
- end;
- procedure TTestModule.TestAdvRecord_ClassConstructor_Program;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TPoint = record',
- ' class var x: longint;',
- ' class procedure Fly; static;',
- ' class constructor Init;',
- ' end;',
- 'var count: word;',
- 'class procedure Tpoint.Fly;',
- 'begin',
- 'end;',
- 'class constructor tpoint.init;',
- 'begin',
- ' count:=count+1;',
- ' x:=x+3;',
- ' tpoint.x:=tpoint.x+4;',
- ' fly;',
- ' tpoint.fly;',
- 'end;',
- 'var r: TPoint;',
- 'begin',
- ' r.x:=r.x+10;',
- ' r.Fly;',
- ' r.Fly();',
- '']);
- ConvertProgram;
- CheckSource('TestAdvRecord_ClassConstructor_Program',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' this.Fly = function () {',
- ' };',
- '}, true);',
- 'this.count = 0;',
- 'this.r = this.TPoint.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '(function () {',
- ' $mod.count = $mod.count + 1;',
- ' $mod.TPoint.x = $mod.TPoint.x + 3;',
- ' $mod.TPoint.x = $mod.TPoint.x + 4;',
- ' $mod.TPoint.Fly();',
- ' $mod.TPoint.Fly();',
- '})();',
- '$mod.TPoint.x = $mod.r.x + 10;',
- '$mod.TPoint.Fly();',
- '$mod.TPoint.Fly();',
- '']));
- end;
- procedure TTestModule.TestAdvRecord_ClassConstructor_Unit;
- begin
- StartUnit(false);
- Add([
- 'interface',
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TPoint = record',
- ' class var x: longint;',
- ' class procedure Fly; static;',
- ' class constructor Init;',
- ' end;',
- 'implementation',
- 'var count: word;',
- 'class procedure Tpoint.Fly;',
- 'begin',
- 'end;',
- 'class constructor tpoint.init;',
- 'begin',
- ' count:=count+1;',
- ' x:=3;',
- ' tpoint.x:=4;',
- ' fly;',
- ' tpoint.fly;',
- 'end;',
- '']);
- ConvertUnit;
- CheckSource('TestAdvRecord_ClassConstructor_Unit',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' this.Fly = function () {',
- ' };',
- '}, true);',
- '']),
- LinesToStr([ // $mod.$init
- '(function () {',
- ' $impl.count = $impl.count + 1;',
- ' $mod.TPoint.x = 3;',
- ' $mod.TPoint.x = 4;',
- ' $mod.TPoint.Fly();',
- ' $mod.TPoint.Fly();',
- '})();',
- '']),
- LinesToStr([ // $mod.$main
- '$impl.count = 0;',
- '']));
- end;
- procedure TTestModule.TestClass_TObjectDefaultConstructor;
- begin
- StartProgram(false);
- Add(['type',
- ' TObject = class',
- ' public',
- ' constructor Create;',
- ' destructor Destroy;',
- ' end;',
- ' TBird = TObject;',
- 'constructor tobject.create;',
- 'begin end;',
- 'destructor tobject.destroy;',
- 'begin end;',
- 'var Obj: tobject;',
- 'begin',
- ' obj:=tobject.create;',
- ' obj:=tobject.create();',
- ' obj:=tbird.create;',
- ' obj:=tbird.create();',
- ' obj:=obj.create();',
- ' obj.destroy;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_TObjectDefaultConstructor',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(){',
- ' return this;',
- ' };',
- ' this.Destroy = function(){',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.TObject.$create("Create");',
- '$mod.Obj = $mod.TObject.$create("Create");',
- '$mod.Obj = $mod.TObject.$create("Create");',
- '$mod.Obj = $mod.TObject.$create("Create");',
- '$mod.Obj = $mod.Obj.Create();',
- '$mod.Obj.$destroy("Destroy");',
- '']));
- end;
- procedure TTestModule.TestClass_TObjectConstructorWithParams;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' public');
- Add(' constructor Create(Par: longint);');
- Add(' end;');
- Add('constructor tobject.create(par: longint);');
- Add('begin end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj:=tobject.create(3);');
- ConvertProgram;
- CheckSource('TestClass_TObjectConstructorWithParams',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(Par){',
- ' return this;',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.TObject.$create("Create",[3]);'
- ]));
- end;
- procedure TTestModule.TestClass_TObjectConstructorWithDefaultParam;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' public');
- Add(' constructor Create;');
- Add(' end;');
- Add(' TTest = class(TObject)');
- Add(' public');
- Add(' constructor Create(const Par: longint = 1);');
- Add(' end;');
- Add('constructor tobject.create;');
- Add('begin end;');
- Add('constructor ttest.create(const par: longint);');
- Add('begin end;');
- Add('var t: ttest;');
- Add('begin');
- Add(' t:=ttest.create;');
- Add(' t:=ttest.create(2);');
- ConvertProgram;
- CheckSource('TestClass_TObjectConstructorWithDefaultParam',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(){',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TTest", this.TObject, function () {',
- ' this.Create$1 = function (Par) {',
- ' return this;',
- ' };',
- '});',
- 'this.t = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.t = $mod.TTest.$create("Create$1", [1]);',
- '$mod.t = $mod.TTest.$create("Create$1", [2]);'
- ]));
- end;
- procedure TTestModule.TestClass_Var;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' public',
- ' vI: longint;',
- ' constructor Create(Par: longint);',
- ' end;',
- 'constructor tobject.create(par: longint);',
- 'begin',
- ' vi:=par+3',
- 'end;',
- 'var Obj: tobject;',
- 'begin',
- ' obj:=tobject.create(4);',
- ' obj.vi:=obj.VI+5;']);
- ConvertProgram;
- CheckSource('TestClass_Var',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' this.vI = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(Par){',
- ' this.vI = Par+3;',
- ' return this;',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.TObject.$create("Create",[4]);',
- '$mod.Obj.vI = $mod.Obj.vI + 5;'
- ]));
- end;
- procedure TTestModule.TestClass_Method;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' public');
- Add(' vI: longint;');
- Add(' Sub: TObject;');
- Add(' constructor Create;');
- Add(' function GetIt(Par: longint): tobject;');
- Add(' end;');
- Add('constructor tobject.create; begin end;');
- Add('function tobject.getit(par: longint): tobject;');
- Add('begin');
- Add(' Self.vi:=par+3;');
- Add(' Result:=self.sub;');
- Add('end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj:=tobject.create;');
- Add(' obj.getit(4);');
- Add(' obj.sub.sub:=nil;');
- Add(' obj.sub.getit(5);');
- Add(' obj.sub.getit(6).SUB:=nil;');
- Add(' obj.sub.getit(7).GETIT(8);');
- Add(' obj.sub.getit(9).SuB.getit(10);');
- ConvertProgram;
- CheckSource('TestClass_Method',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' this.vI = 0;',
- ' this.Sub = null;',
- ' };',
- ' this.$final = function () {',
- ' this.Sub = undefined;',
- ' };',
- ' this.Create = function(){',
- ' return this;',
- ' };',
- ' this.GetIt = function(Par){',
- ' var Result = null;',
- ' this.vI = Par + 3;',
- ' Result = this.Sub;',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.TObject.$create("Create");',
- '$mod.Obj.GetIt(4);',
- '$mod.Obj.Sub.Sub=null;',
- '$mod.Obj.Sub.GetIt(5);',
- '$mod.Obj.Sub.GetIt(6).Sub=null;',
- '$mod.Obj.Sub.GetIt(7).GetIt(8);',
- '$mod.Obj.Sub.GetIt(9).Sub.GetIt(10);'
- ]));
- end;
- procedure TTestModule.TestClass_Implementation;
- begin
- StartUnit(false);
- Add([
- 'interface',
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- 'implementation',
- 'type',
- ' TIntClass = class',
- ' constructor Create; reintroduce;',
- ' class procedure DoGlob;',
- ' end;',
- 'constructor tintclass.create;',
- 'begin',
- ' inherited;',
- ' inherited create;',
- ' doglob;',
- 'end;',
- 'class procedure tintclass.doglob;',
- 'begin',
- 'end;',
- 'constructor tobject.create;',
- 'var',
- ' iC: tintclass;',
- 'begin',
- ' ic:=tintclass.create;',
- ' tintclass.doglob;',
- ' ic.doglob;',
- 'end;',
- 'initialization',
- ' tintclass.doglob;',
- '']);
- ConvertUnit;
- CheckSource('TestClass_Implementation',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' var iC = null;',
- ' iC = $impl.TIntClass.$create("Create$1");',
- ' $impl.TIntClass.DoGlob();',
- ' iC.$class.DoGlob();',
- ' return this;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '$impl.TIntClass.DoGlob();',
- '']),
- LinesToStr([
- 'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
- ' this.Create$1 = function () {',
- ' $mod.TObject.Create.call(this);',
- ' $mod.TObject.Create.call(this);',
- ' this.$class.DoGlob();',
- ' return this;',
- ' };',
- ' this.DoGlob = function () {',
- ' };',
- '});',
- '']));
- end;
- procedure TTestModule.TestClass_Inheritance;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' public');
- Add(' constructor Create;');
- Add(' end;');
- Add(' TClassA = class');
- Add(' end;');
- Add(' TClassB = class(TObject)');
- Add(' procedure ProcB;');
- Add(' end;');
- Add('constructor tobject.create; begin end;');
- Add('procedure tclassb.procb; begin end;');
- Add('var');
- Add(' oO: TObject;');
- Add(' oA: TClassA;');
- Add(' oB: TClassB;');
- Add('begin');
- Add(' oO:=tobject.Create;');
- Add(' oA:=tclassa.Create;');
- Add(' ob:=tclassb.Create;');
- Add(' if oo is tclassa then ;');
- Add(' ob:=oo as tclassb;');
- Add(' (oo as tclassb).procb;');
- ConvertProgram;
- CheckSource('TestClass_Inheritance',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this,"TClassA",this.TObject,function(){',
- '});',
- 'rtl.createClass(this,"TClassB",this.TObject,function(){',
- ' this.ProcB = function () {',
- ' };',
- '});',
- 'this.oO = null;',
- 'this.oA = null;',
- 'this.oB = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.oO = $mod.TObject.$create("Create");',
- '$mod.oA = $mod.TClassA.$create("Create");',
- '$mod.oB = $mod.TClassB.$create("Create");',
- 'if ($mod.TClassA.isPrototypeOf($mod.oO));',
- '$mod.oB = rtl.as($mod.oO, $mod.TClassB);',
- 'rtl.as($mod.oO, $mod.TClassB).ProcB();'
- ]));
- end;
- procedure TTestModule.TestClass_TypeAlias;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IObject = interface',
- ' end;',
- ' IBird = type IObject;',
- ' TObject = class',
- ' end;',
- ' TBird = type TObject;',
- 'var',
- ' oObj: TObject;',
- ' oBird: TBird;',
- ' IntfObj: IObject;',
- ' IntfBird: IBird;',
- 'begin',
- ' oObj:=oBird;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_TypeAlias',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IObject", "{B92D5841-6F2A-306A-8000-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{4B0D080B-C0F6-387B-AE88-F10981585074}", [], this.IObject);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- '});',
- 'this.oObj = null;',
- 'this.oBird = null;',
- 'this.IntfObj = null;',
- 'this.IntfBird = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.oObj = $mod.oBird;',
- '']));
- end;
- procedure TTestModule.TestClass_AbstractMethod;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' public');
- Add(' procedure DoIt; virtual; abstract;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestClass_AbstractMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestClass_CallInherited_ProcNoParams;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure DoAbstract; virtual; abstract;',
- ' procedure DoVirtual; virtual;',
- ' procedure DoIt;',
- ' end;',
- ' TA = class',
- ' procedure doabstract; override;',
- ' procedure dovirtual; override;',
- ' procedure DoSome;',
- ' end;',
- 'procedure tobject.dovirtual;',
- 'begin',
- ' inherited; // call non existing ancestor -> ignore silently',
- 'end;',
- 'procedure tobject.doit;',
- 'begin',
- 'end;',
- 'procedure ta.doabstract;',
- 'begin',
- ' inherited dovirtual; // call TObject.DoVirtual',
- 'end;',
- 'procedure ta.dovirtual;',
- 'begin',
- ' inherited; // call TObject.DoVirtual',
- ' inherited dovirtual; // call TObject.DoVirtual',
- ' inherited dovirtual(); // call TObject.DoVirtual',
- ' doit;',
- ' doit();',
- 'end;',
- 'procedure ta.dosome;',
- 'begin',
- ' inherited; // call non existing ancestor method -> silently ignore',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestClass_CallInherited_ProcNoParams',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoVirtual = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TA", this.TObject, function () {',
- ' this.DoAbstract = function () {',
- ' $mod.TObject.DoVirtual.call(this);',
- ' };',
- ' this.DoVirtual = function () {',
- ' $mod.TObject.DoVirtual.call(this);',
- ' $mod.TObject.DoVirtual.call(this);',
- ' $mod.TObject.DoVirtual.call(this);',
- ' this.DoIt();',
- ' this.DoIt();',
- ' };',
- ' this.DoSome = function () {',
- ' };',
- '});'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestClass_CallInherited_WithParams;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure DoAbstract(pA: longint; pB: longint = 0); virtual; abstract;',
- ' procedure DoVirtual(pA: longint; pB: longint = 0); virtual;',
- ' procedure DoIt(pA: longint; pB: longint = 0);',
- ' procedure DoIt2(pA: longint = 1; pB: longint = 2);',
- ' function GetIt(pA: longint = 1; pB: longint = 2): longint;',
- ' end;',
- ' TClassA = class',
- ' procedure DoAbstract(pA: longint; pB: longint = 0); override;',
- ' procedure DoVirtual(pA: longint; pB: longint = 0); override;',
- ' function GetIt(pA: longint = 1; pB: longint = 2): longint;',
- ' end;',
- 'procedure tobject.dovirtual(pa: longint; pb: longint = 0);',
- 'begin',
- 'end;',
- 'procedure tobject.doit(pa: longint; pb: longint = 0);',
- 'begin',
- 'end;',
- 'procedure tobject.doit2(pa: longint; pb: longint = 0);',
- 'begin',
- 'end;',
- 'function tobject.getit(pa: longint; pb: longint = 0): longint;',
- 'begin',
- 'end;',
- 'procedure tclassa.doabstract(pa: longint; pb: longint = 0);',
- 'begin',
- ' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)',
- ' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)',
- 'end;',
- 'procedure tclassa.dovirtual(pa: longint; pb: longint = 0);',
- 'begin',
- ' inherited; // call TObject.DoVirtual(pA,pB)',
- ' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)',
- ' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)',
- ' doit(pa,pb);',
- ' doit(pa);',
- ' doit2(pa);',
- ' doit2;',
- 'end;',
- 'function tclassa.getit(pa: longint; pb: longint = 0): longint;',
- 'begin',
- ' pa:=inherited;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestClass_CallInherited_WithParams',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoVirtual = function (pA,pB) {',
- ' };',
- ' this.DoIt = function (pA,pB) {',
- ' };',
- ' this.DoIt2 = function (pA,pB) {',
- ' };',
- ' this.GetIt = function (pA, pB) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass(this, "TClassA", this.TObject, function () {',
- ' this.DoAbstract = function (pA,pB) {',
- ' $mod.TObject.DoVirtual.call(this,pA,pB);',
- ' $mod.TObject.DoVirtual.call(this,pA,0);',
- ' };',
- ' this.DoVirtual = function (pA,pB) {',
- ' $mod.TObject.DoVirtual.apply(this, arguments);',
- ' $mod.TObject.DoVirtual.call(this,pA,pB);',
- ' $mod.TObject.DoVirtual.call(this,pA,0);',
- ' this.DoIt(pA,pB);',
- ' this.DoIt(pA,0);',
- ' this.DoIt2(pA,2);',
- ' this.DoIt2(1,2);',
- ' };',
- ' this.GetIt$1 = function (pA, pB) {',
- ' var Result = 0;',
- ' pA = $mod.TObject.GetIt.apply(this, arguments);',
- ' return Result;',
- ' };',
- '});'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestClasS_CallInheritedConstructor;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' constructor Create; virtual;');
- Add(' constructor CreateWithB(b: boolean);');
- Add(' end;');
- Add(' TA = class');
- Add(' constructor Create; override;');
- Add(' constructor CreateWithC(c: char);');
- Add(' procedure DoIt;');
- Add(' class function DoSome: TObject;');
- Add(' end;');
- Add('constructor tobject.create;');
- Add('begin');
- Add(' inherited; // call non existing ancestor -> ignore silently');
- Add('end;');
- Add('constructor tobject.createwithb(b: boolean);');
- Add('begin');
- Add(' inherited; // call non existing ancestor -> ignore silently');
- Add(' create; // normal call');
- Add('end;');
- Add('constructor ta.create;');
- Add('begin');
- Add(' inherited; // normal call TObject.Create');
- Add(' inherited create; // normal call TObject.Create');
- Add(' inherited createwithb(false); // normal call TObject.CreateWithB');
- Add('end;');
- Add('constructor ta.createwithc(c: char);');
- Add('begin');
- Add(' inherited create; // call TObject.Create');
- Add(' inherited createwithb(true); // call TObject.CreateWithB');
- Add(' doit;');
- Add(' doit();');
- Add(' dosome;');
- Add('end;');
- Add('procedure ta.doit;');
- Add('begin');
- Add(' create; // normal call');
- Add(' createwithb(false); // normal call');
- Add(' createwithc(''c''); // normal call');
- Add('end;');
- Add('class function ta.dosome: TObject;');
- Add('begin');
- Add(' Result:=create; // constructor');
- Add(' Result:=createwithb(true); // constructor');
- Add(' Result:=createwithc(''c''); // constructor');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestClass_CallInheritedConstructor',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- ' this.CreateWithB = function (b) {',
- ' this.Create();',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TA", this.TObject, function () {',
- ' this.Create = function () {',
- ' $mod.TObject.Create.call(this);',
- ' $mod.TObject.Create.call(this);',
- ' $mod.TObject.CreateWithB.call(this, false);',
- ' return this;',
- ' };',
- ' this.CreateWithC = function (c) {',
- ' $mod.TObject.Create.call(this);',
- ' $mod.TObject.CreateWithB.call(this, true);',
- ' this.DoIt();',
- ' this.DoIt();',
- ' this.$class.DoSome();',
- ' return this;',
- ' };',
- ' this.DoIt = function () {',
- ' this.Create();',
- ' this.CreateWithB(false);',
- ' this.CreateWithC("c");',
- ' };',
- ' this.DoSome = function () {',
- ' var Result = null;',
- ' Result = this.$create("Create");',
- ' Result = this.$create("CreateWithB", [true]);',
- ' Result = this.$create("CreateWithC", ["c"]);',
- ' return Result;',
- ' };',
- '});'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestClass_ClassVar_Assign;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' public',
- ' class var vI: longint;',
- ' class var Sub: TObject;',
- ' constructor Create;',
- ' class function GetIt(var Par: longint): tobject;',
- ' end;',
- 'constructor tobject.create;',
- 'begin',
- ' vi:=vi+1;',
- ' Self.vi:=Self.vi+1;',
- ' inc(vi);',
- 'end;',
- 'class function tobject.getit(var par: longint): tobject;',
- 'begin',
- ' vi:=vi+3;',
- ' Self.vi:=Self.vi+4;',
- ' inc(vi);',
- ' Result:=self.sub;',
- ' GetIt(vi);',
- 'end;',
- 'var Obj: tobject;',
- 'begin',
- ' obj:=tobject.create;',
- ' tobject.vi:=3;',
- ' if tobject.vi=4 then ;',
- ' tobject.sub:=nil;',
- ' obj.sub:=nil;',
- ' obj.sub.sub:=nil;']);
- ConvertProgram;
- CheckSource('TestClass_ClassVar_Assign',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.vI = 0;',
- ' this.Sub = null;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(){',
- ' $mod.TObject.vI = this.vI+1;',
- ' $mod.TObject.vI = this.vI+1;',
- ' $mod.TObject.vI += 1;',
- ' return this;',
- ' };',
- ' this.GetIt = function(Par){',
- ' var Result = null;',
- ' $mod.TObject.vI = this.vI + 3;',
- ' $mod.TObject.vI = this.vI + 4;',
- ' $mod.TObject.vI += 1;',
- ' Result = this.Sub;',
- ' this.GetIt({',
- ' p: $mod.TObject,',
- ' get: function () {',
- ' return this.p.vI;',
- ' },',
- ' set: function (v) {',
- ' this.p.vI = v;',
- ' }',
- ' });',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.TObject.$create("Create");',
- '$mod.TObject.vI = 3;',
- 'if ($mod.TObject.vI === 4);',
- '$mod.TObject.Sub=null;',
- '$mod.TObject.Sub=null;',
- '$mod.TObject.Sub=null;',
- '']));
- end;
- procedure TTestModule.TestClass_CallClassMethod;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' public');
- Add(' class var vI: longint;');
- Add(' class var Sub: TObject;');
- Add(' constructor Create;');
- Add(' function GetMore(Par: longint): longint;');
- Add(' class function GetIt(Par: longint): tobject;');
- Add(' end;');
- Add('constructor tobject.create;');
- Add('begin');
- Add(' sub:=getit(3);');
- Add(' vi:=getmore(4);');
- Add(' sub:=Self.getit(5);');
- Add(' vi:=Self.getmore(6);');
- Add('end;');
- Add('function tobject.getmore(par: longint): longint;');
- Add('begin');
- Add(' sub:=getit(11);');
- Add(' vi:=getmore(12);');
- Add(' sub:=self.getit(13);');
- Add(' vi:=self.getmore(14);');
- Add('end;');
- Add('class function tobject.getit(par: longint): tobject;');
- Add('begin');
- Add(' sub:=getit(21);');
- Add(' vi:=sub.getmore(22);');
- Add(' sub:=self.getit(23);');
- Add(' vi:=self.sub.getmore(24);');
- Add('end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj:=tobject.create;');
- Add(' tobject.getit(5);');
- Add(' obj.getit(6);');
- Add(' obj.sub.getit(7);');
- Add(' obj.sub.getit(8).SUB:=nil;');
- Add(' obj.sub.getit(9).GETIT(10);');
- Add(' obj.sub.getit(11).SuB.getit(12);');
- ConvertProgram;
- CheckSource('TestClass_CallClassMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this,"TObject",null,function(){',
- ' this.vI = 0;',
- ' this.Sub = null;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(){',
- ' $mod.TObject.Sub = this.$class.GetIt(3);',
- ' $mod.TObject.vI = this.GetMore(4);',
- ' $mod.TObject.Sub = this.$class.GetIt(5);',
- ' $mod.TObject.vI = this.GetMore(6);',
- ' return this;',
- ' };',
- ' this.GetMore = function(Par){',
- ' var Result = 0;',
- ' $mod.TObject.Sub = this.$class.GetIt(11);',
- ' $mod.TObject.vI = this.GetMore(12);',
- ' $mod.TObject.Sub = this.$class.GetIt(13);',
- ' $mod.TObject.vI = this.GetMore(14);',
- ' return Result;',
- ' };',
- ' this.GetIt = function(Par){',
- ' var Result = null;',
- ' $mod.TObject.Sub = this.GetIt(21);',
- ' $mod.TObject.vI = this.Sub.GetMore(22);',
- ' $mod.TObject.Sub = this.GetIt(23);',
- ' $mod.TObject.vI = this.Sub.GetMore(24);',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.TObject.$create("Create");',
- '$mod.TObject.GetIt(5);',
- '$mod.Obj.$class.GetIt(6);',
- '$mod.Obj.Sub.$class.GetIt(7);',
- '$mod.TObject.Sub=null;',
- '$mod.Obj.Sub.$class.GetIt(9).$class.GetIt(10);',
- '$mod.Obj.Sub.$class.GetIt(11).Sub.$class.GetIt(12);',
- '']));
- end;
- procedure TTestModule.TestClass_CallClassMethodStatic;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' public',
- ' class function Fly: tobject; static;',
- ' end;',
- 'class function tobject.Fly: tobject;',
- 'begin',
- ' Result.Fly;',
- ' Result.Fly();',
- ' Fly;',
- ' Fly();',
- ' Fly.Fly;',
- ' Fly.Fly();',
- 'end;',
- 'var Obj: tobject;',
- 'begin',
- ' obj.Fly;',
- ' obj.Fly();',
- ' with obj do begin',
- ' Fly;',
- ' Fly();',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_CallClassMethodStatic',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Fly = function () {',
- ' var Result = null;',
- ' $mod.TObject.Fly();',
- ' $mod.TObject.Fly();',
- ' $mod.TObject.Fly();',
- ' $mod.TObject.Fly();',
- ' $mod.TObject.Fly();',
- ' $mod.TObject.Fly();',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.TObject.Fly();',
- '$mod.TObject.Fly();',
- 'var $with = $mod.Obj;',
- '$with.Fly();',
- '$with.Fly();',
- '']));
- end;
- procedure TTestModule.TestClass_Property;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' Fx: longint;');
- Add(' Fy: longint;');
- Add(' function GetInt: longint;');
- Add(' procedure SetInt(Value: longint);');
- Add(' procedure DoIt;');
- Add(' property IntA: longint read Fx write Fy;');
- Add(' property IntB: longint read GetInt write SetInt;');
- Add(' end;');
- Add('function tobject.getint: longint;');
- Add('begin');
- Add(' result:=fx;');
- Add('end;');
- Add('procedure tobject.setint(value: longint);');
- Add('begin');
- Add(' if value=fy then exit;');
- Add(' fy:=value;');
- Add('end;');
- Add('procedure tobject.doit;');
- Add('begin');
- Add(' IntA:=IntA+1;');
- Add(' Self.IntA:=Self.IntA+1;');
- Add(' IntB:=IntB+1;');
- Add(' Self.IntB:=Self.IntB+1;');
- Add('end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj.inta:=obj.inta+1;');
- Add(' if obj.intb=2 then;');
- Add(' obj.intb:=obj.intb+2;');
- Add(' obj.setint(obj.inta);');
- ConvertProgram;
- CheckSource('TestClass_Property',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Fx = 0;',
- ' this.Fy = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetInt = function () {',
- ' var Result = 0;',
- ' Result = this.Fx;',
- ' return Result;',
- ' };',
- ' this.SetInt = function (Value) {',
- ' if (Value === this.Fy) return;',
- ' this.Fy = Value;',
- ' };',
- ' this.DoIt = function () {',
- ' this.Fy = this.Fx + 1;',
- ' this.Fy = this.Fx + 1;',
- ' this.SetInt(this.GetInt() + 1);',
- ' this.SetInt(this.GetInt() + 1);',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj.Fy = $mod.Obj.Fx + 1;',
- 'if ($mod.Obj.GetInt() === 2);',
- '$mod.Obj.SetInt($mod.Obj.GetInt() + 2);',
- '$mod.Obj.SetInt($mod.Obj.Fx);'
- ]));
- end;
- procedure TTestModule.TestClass_Property_ClassMethod;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' class var Fx: longint;',
- ' class var Fy: longint;',
- ' class function GetInt: longint;',
- ' class procedure SetInt(Value: longint);',
- ' end;',
- ' TBird = class',
- ' class procedure DoIt;',
- ' class property IntA: longint read Fx write Fy;',
- ' class property IntB: longint read GetInt write SetInt;',
- ' end;',
- 'class function tobject.getint: longint;',
- 'begin',
- ' result:=fx;',
- 'end;',
- 'class procedure tobject.setint(value: longint);',
- 'begin',
- 'end;',
- 'class procedure tbird.doit;',
- 'begin',
- ' FX:=3;',
- ' IntA:=IntA+1;',
- ' Self.IntA:=Self.IntA+1;',
- ' IntB:=IntB+1;',
- ' Self.IntB:=Self.IntB+1;',
- ' with Self do begin',
- ' FX:=11;',
- ' IntA:=IntA+12;',
- ' IntB:=IntB+13;',
- ' end;',
- 'end;',
- 'var Obj: tbird;',
- 'begin',
- ' tbird.fx:=tbird.fx+1;',
- ' tbird.inta:=tbird.inta+1;',
- ' if tbird.intb=2 then;',
- ' tbird.intb:=tbird.intb+2;',
- ' tbird.setint(tbird.inta);',
- ' obj.inta:=obj.inta+1;',
- ' if obj.intb=2 then;',
- ' obj.intb:=obj.intb+2;',
- ' obj.setint(obj.inta);',
- ' with Tbird do begin',
- ' FX:=FY+1;',
- ' inta:=inta+2;',
- ' intb:=intb+3;',
- ' end;',
- ' with Obj do begin',
- ' FX:=FY+1;',
- ' inta:=inta+2;',
- ' intb:=intb+3;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_Property_ClassMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.Fx = 0;',
- ' this.Fy = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetInt = function () {',
- ' var Result = 0;',
- ' Result = this.Fx;',
- ' return Result;',
- ' };',
- ' this.SetInt = function (Value) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' $mod.TObject.Fx = 3;',
- ' $mod.TObject.Fy = this.Fx + 1;',
- ' $mod.TObject.Fy = this.Fx + 1;',
- ' this.SetInt(this.GetInt() + 1);',
- ' this.SetInt(this.GetInt() + 1);',
- ' $mod.TObject.Fx = 11;',
- ' $mod.TObject.Fy = this.Fx + 12;',
- ' this.SetInt(this.GetInt() + 13);',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.TObject.Fx = $mod.TBird.Fx + 1;',
- '$mod.TObject.Fy = $mod.TBird.Fx + 1;',
- 'if ($mod.TBird.GetInt() === 2);',
- '$mod.TBird.SetInt($mod.TBird.GetInt() + 2);',
- '$mod.TBird.SetInt($mod.TBird.Fx);',
- '$mod.TObject.Fy = $mod.Obj.Fx + 1;',
- 'if ($mod.Obj.$class.GetInt() === 2);',
- '$mod.Obj.$class.SetInt($mod.Obj.$class.GetInt() + 2);',
- '$mod.Obj.$class.SetInt($mod.Obj.Fx);',
- 'var $with = $mod.TBird;',
- '$mod.TObject.Fx = $with.Fy + 1;',
- '$mod.TObject.Fy = $with.Fx + 2;',
- '$with.SetInt($with.GetInt() + 3);',
- 'var $with1 = $mod.Obj;',
- '$mod.TObject.Fx = $with1.Fy + 1;',
- '$mod.TObject.Fy = $with1.Fx + 2;',
- '$with1.$class.SetInt($with1.$class.GetInt() + 3);',
- '']));
- end;
- procedure TTestModule.TestClass_Property_Indexed;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' FItems: array of longint;',
- ' function GetItems(Index: longint): longint;',
- ' procedure SetItems(Index: longint; Value: longint);',
- ' procedure DoIt;',
- ' property Items[Index: longint]: longint read getitems write setitems;',
- ' end;',
- 'function tobject.getitems(index: longint): longint;',
- 'begin',
- ' Result:=fitems[index];',
- 'end;',
- 'procedure tobject.setitems(index: longint; value: longint);',
- 'begin',
- ' fitems[index]:=value;',
- 'end;',
- 'procedure tobject.doit;',
- 'begin',
- ' items[1]:=2;',
- ' items[3]:=items[4];',
- ' self.items[5]:=self.items[6];',
- ' items[items[7]]:=items[items[8]];',
- 'end;',
- 'var Obj: tobject;',
- 'begin',
- ' obj.Items[11]:=obj.Items[12];',
- '']);
- ConvertProgram;
- CheckSource('TestClass_Property_Indexed',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FItems = [];',
- ' };',
- ' this.$final = function () {',
- ' this.FItems = undefined;',
- ' };',
- ' this.GetItems = function (Index) {',
- ' var Result = 0;',
- ' Result = this.FItems[Index];',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' this.FItems[Index] = Value;',
- ' };',
- ' this.DoIt = function () {',
- ' this.SetItems(1, 2);',
- ' this.SetItems(3,this.GetItems(4));',
- ' this.SetItems(5,this.GetItems(6));',
- ' this.SetItems(this.GetItems(7), this.GetItems(this.GetItems(8)));',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj.SetItems(11,$mod.Obj.GetItems(12));'
- ]));
- end;
- procedure TTestModule.TestClass_Property_IndexSpec;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (red, blue);',
- ' TObject = class',
- ' function GetIntBool(Index: longint): boolean; virtual; abstract;',
- ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
- ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
- ' procedure SetEnumBool(Index: TEnum; b: boolean); virtual; abstract;',
- ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
- ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
- ' property B1: boolean index 1 read GetIntBool write SetIntBool;',
- ' property B2: boolean index TEnum.blue read GetEnumBool write SetEnumBool;',
- ' property B3: boolean index ord(red) read GetIntBool write SetIntBool;',
- ' property I1[A: String]: boolean index ord(blue) read GetStrIntBool write SetStrIntBool;',
- ' end;',
- 'procedure DoIt(b: boolean); begin end;',
- 'var',
- ' o: TObject;',
- 'begin',
- ' o.B1:=o.B1;',
- ' o.B2:=o.B2;',
- ' o.B3:=o.B3;',
- ' o.I1[''a'']:=o.I1[''b''];',
- ' doit(o.b1);',
- ' doit(o.b2);',
- ' doit(o.i1[''c'']);',
- '']);
- ConvertProgram;
- CheckSource('TestClass_Property_IndexSpec',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.DoIt = function (b) {',
- '};',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.o.SetIntBool(1, $mod.o.GetIntBool(1));',
- '$mod.o.SetEnumBool($mod.TEnum.blue, $mod.o.GetEnumBool($mod.TEnum.blue));',
- '$mod.o.SetIntBool(0, $mod.o.GetIntBool(0));',
- '$mod.o.SetStrIntBool("a", 1, $mod.o.GetStrIntBool("b", 1));',
- '$mod.DoIt($mod.o.GetIntBool(1));',
- '$mod.DoIt($mod.o.GetEnumBool($mod.TEnum.blue));',
- '$mod.DoIt($mod.o.GetStrIntBool("c", 1));',
- '']));
- end;
- procedure TTestModule.TestClass_PropertyOfTypeArray;
- begin
- StartProgram(false);
- Add('type');
- Add(' TArray = array of longint;');
- Add(' TObject = class');
- Add(' FItems: TArray;');
- Add(' function GetItems: tarray;');
- Add(' procedure SetItems(Value: tarray);');
- Add(' property Items: tarray read getitems write setitems;');
- Add(' procedure SetNumbers(const Value: tarray);');
- Add(' property Numbers: tarray write setnumbers;');
- Add(' end;');
- Add('function tobject.getitems: tarray;');
- Add('begin');
- Add(' Result:=fitems;');
- Add('end;');
- Add('procedure tobject.setitems(value: tarray);');
- Add('begin');
- Add(' fitems:=value;');
- Add(' fitems:=nil;');
- Add(' Items:=nil;');
- Add(' Items:=Items;');
- Add(' Items[1]:=2;');
- Add(' fitems[3]:=Items[4];');
- Add(' Items[5]:=Items[6];');
- Add(' Self.Items[7]:=8;');
- Add(' Self.Items[9]:=Self.Items[10];');
- Add(' Items[Items[11]]:=Items[Items[12]];');
- Add('end;');
- Add('procedure tobject.SetNumbers(const Value: tarray);');
- Add('begin;');
- Add(' Numbers:=nil;');
- Add(' Numbers:=Value;');
- Add(' Self.Numbers:=Value;');
- Add('end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj.items:=nil;');
- Add(' obj.items:=obj.items;');
- Add(' obj.items[11]:=obj.items[12];');
- ConvertProgram;
- CheckSource('TestClass_PropertyOfTypeArray',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FItems = [];',
- ' };',
- ' this.$final = function () {',
- ' this.FItems = undefined;',
- ' };',
- ' this.GetItems = function () {',
- ' var Result = [];',
- ' Result = rtl.arrayRef(this.FItems);',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Value) {',
- ' this.FItems = rtl.arrayRef(Value);',
- ' this.FItems = [];',
- ' this.SetItems([]);',
- ' this.SetItems(rtl.arrayRef(this.GetItems()));',
- ' this.GetItems()[1] = 2;',
- ' this.FItems[3] = this.GetItems()[4];',
- ' this.GetItems()[5] = this.GetItems()[6];',
- ' this.GetItems()[7] = 8;',
- ' this.GetItems()[9] = this.GetItems()[10];',
- ' this.GetItems()[this.GetItems()[11]] = this.GetItems()[this.GetItems()[12]];',
- ' };',
- ' this.SetNumbers = function (Value) {',
- ' this.SetNumbers([]);',
- ' this.SetNumbers(Value);',
- ' this.SetNumbers(Value);',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj.SetItems([]);',
- '$mod.Obj.SetItems($mod.Obj.GetItems());',
- '$mod.Obj.GetItems()[11] = $mod.Obj.GetItems()[12];'
- ]));
- end;
- procedure TTestModule.TestClass_PropertyDefault;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArray = array of longint;',
- ' TObject = class',
- ' end;',
- ' TBird = class',
- ' FItems: TArray;',
- ' function GetItems(Index: longint): longint;',
- ' procedure SetItems(Index, Value: longint);',
- ' property Items[Index: longint]: longint read getitems write setitems; default;',
- ' end;',
- 'function TBird.getitems(index: longint): longint;',
- 'begin',
- 'end;',
- 'procedure TBird.setitems(index, value: longint);',
- 'begin',
- ' Self[1]:=2;',
- ' Self[3]:=Self[index];',
- ' Self[index]:=Self[Self[value]];',
- ' Self[Self[4]]:=value;',
- 'end;',
- 'var',
- ' Bird: TBird;',
- ' Obj: TObject;',
- 'begin',
- ' bird[11]:=12;',
- ' bird[13]:=bird[14];',
- ' bird[Bird[15]]:=bird[Bird[15]];',
- ' TBird(obj)[16]:=TBird(obj)[17];',
- ' (obj as tbird)[18]:=19;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_PropertyDefault',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FItems = [];',
- ' };',
- ' this.$final = function () {',
- ' this.FItems = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- ' this.GetItems = function (Index) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' this.SetItems(1, 2);',
- ' this.SetItems(3, this.GetItems(Index));',
- ' this.SetItems(Index, this.GetItems(this.GetItems(Value)));',
- ' this.SetItems(this.GetItems(4), Value);',
- ' };',
- '});',
- 'this.Bird = null;',
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Bird.SetItems(11, 12);',
- '$mod.Bird.SetItems(13, $mod.Bird.GetItems(14));',
- '$mod.Bird.SetItems($mod.Bird.GetItems(15), $mod.Bird.GetItems($mod.Bird.GetItems(15)));',
- '$mod.Obj.SetItems(16, $mod.Obj.GetItems(17));',
- 'rtl.as($mod.Obj, $mod.TBird).SetItems(18, 19);',
- '']));
- end;
- procedure TTestModule.TestClass_PropertyDefault_TypecastToOtherDefault;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- ' TAlphaList = class',
- ' function GetAlphas(Index: boolean): Pointer; virtual; abstract;',
- ' procedure SetAlphas(Index: boolean; Value: Pointer); virtual; abstract;',
- ' property Alphas[Index: boolean]: Pointer read getAlphas write setAlphas; default;',
- ' end;',
- ' TBetaList = class',
- ' function GetBetas(Index: longint): Pointer; virtual; abstract;',
- ' procedure SetBetas(Index: longint; Value: Pointer); virtual; abstract;',
- ' property Betas[Index: longint]: Pointer read getBetas write setBetas; default;',
- ' end;',
- ' TBird = class',
- ' procedure DoIt;',
- ' end;',
- 'procedure TBird.DoIt;',
- 'var',
- ' List: TAlphaList;',
- 'begin',
- ' if TBetaList(List[true])[3]=nil then ;',
- ' TBetaList(List[false])[5]:=nil;',
- 'end;',
- 'var',
- ' List: TAlphaList;',
- 'begin',
- ' if TBetaList(List[true])[3]=nil then ;',
- ' TBetaList(List[false])[5]:=nil;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_PropertyDefault_TypecastToOtherDefault',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TAlphaList", this.TObject, function () {',
- '});',
- 'rtl.createClass(this, "TBetaList", this.TObject, function () {',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' var List = null;',
- ' if (List.GetAlphas(true).GetBetas(3) === null) ;',
- ' List.GetAlphas(false).SetBetas(5, null);',
- ' };',
- '});',
- 'this.List = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'if ($mod.List.GetAlphas(true).GetBetas(3) === null) ;',
- '$mod.List.GetAlphas(false).SetBetas(5, null);',
- '']));
- end;
- procedure TTestModule.TestClass_PropertyOverride;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TObject = class');
- Add(' FItem: integer;');
- Add(' function GetItem: integer; external name ''GetItem'';');
- Add(' procedure SetItem(Value: integer); external name ''SetItem'';');
- Add(' property Item: integer read getitem write setitem;');
- Add(' end;');
- Add(' TCar = class');
- Add(' FBag: integer;');
- Add(' function GetBag: integer; external name ''GetBag'';');
- Add(' property Item read getbag;');
- Add(' end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' Car: tcar;');
- Add('begin');
- Add(' Obj.Item:=Obj.Item;');
- Add(' Car.Item:=Car.Item;');
- ConvertProgram;
- CheckSource('TestClass_PropertyOverride',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FItem = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TCar", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FBag = 0;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.Car = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Obj.SetItem($mod.Obj.GetItem());',
- '$mod.Car.SetItem($mod.Car.GetBag());',
- '']));
- end;
- procedure TTestModule.TestClass_PropertyIncVisibility;
- begin
- AddModuleWithIntfImplSrc('unit1.pp',
- LinesToStr([
- 'type',
- ' TNumber = longint;',
- ' TInteger = longint;',
- ' TObject = class',
- ' private',
- ' function GetItems(Index: TNumber): TInteger; virtual; abstract;',
- ' procedure SetItems(Index: TInteger; Value: TNumber); virtual; abstract;',
- ' protected',
- ' property Items[Index: TNumber]: longint read GetItems write SetItems;',
- ' end;']),
- LinesToStr([
- '']));
- StartProgram(true);
- Add([
- 'uses unit1;',
- 'type',
- ' TBird = class',
- ' public',
- ' property Items;',
- ' end;',
- 'procedure DoIt(i: TInteger);',
- 'begin',
- 'end;',
- 'var b: TBird;',
- 'begin',
- ' b.Items[1]:=2;',
- ' b.Items[3]:=b.Items[4];',
- ' DoIt(b.Items[5]);',
- '']);
- ConvertProgram;
- CheckSource('TestClass_PropertyIncVisibility',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TBird", pas.unit1.TObject, function () {',
- '});',
- 'this.DoIt = function (i) {',
- '};',
- 'this.b = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.b.SetItems(1, 2);',
- '$mod.b.SetItems(3, $mod.b.GetItems(4));',
- '$mod.DoIt($mod.b.GetItems(5));'
- ]));
- end;
- procedure TTestModule.TestClass_Assigned;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' b: boolean;');
- Add('begin');
- Add(' if Assigned(obj) then ;');
- Add(' b:=Assigned(obj) or false;');
- ConvertProgram;
- CheckSource('TestClass_Assigned',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.b = false;'
- ]),
- LinesToStr([ // $mod.$main
- 'if ($mod.Obj != null);',
- '$mod.b = ($mod.Obj != null) || false;'
- ]));
- end;
- procedure TTestModule.TestClass_WithClassDoCreate;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' aBool: boolean;');
- Add(' Arr: array of boolean;');
- Add(' constructor Create;');
- Add(' end;');
- Add('constructor TObject.Create; begin end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' b: boolean;');
- Add('begin');
- Add(' with tobject.create do begin');
- Add(' b:=abool;');
- Add(' abool:=b;');
- Add(' b:=arr[1];');
- Add(' arr[2]:=b;');
- Add(' end;');
- Add(' with tobject do');
- Add(' obj:=create;');
- Add(' with obj do begin');
- Add(' create;');
- Add(' b:=abool;');
- Add(' abool:=b;');
- Add(' b:=arr[3];');
- Add(' arr[4]:=b;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestClass_WithClassDoCreate',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.aBool = false;',
- ' this.Arr = [];',
- ' };',
- ' this.$final = function () {',
- ' this.Arr = undefined;',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.b = false;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with = $mod.TObject.$create("Create");',
- '$mod.b = $with.aBool;',
- '$with.aBool = $mod.b;',
- '$mod.b = $with.Arr[1];',
- '$with.Arr[2] = $mod.b;',
- 'var $with1 = $mod.TObject;',
- '$mod.Obj = $with1.$create("Create");',
- 'var $with2 = $mod.Obj;',
- '$with2.Create();',
- '$mod.b = $with2.aBool;',
- '$with2.aBool = $mod.b;',
- '$mod.b = $with2.Arr[3];',
- '$with2.Arr[4] = $mod.b;',
- '']));
- end;
- procedure TTestModule.TestClass_WithClassInstDoProperty;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' FInt: longint;');
- Add(' constructor Create;');
- Add(' function GetSize: longint;');
- Add(' procedure SetSize(Value: longint);');
- Add(' property Int: longint read FInt write FInt;');
- Add(' property Size: longint read GetSize write SetSize;');
- Add(' end;');
- Add('constructor TObject.Create; begin end;');
- Add('function TObject.GetSize: longint; begin; end;');
- Add('procedure TObject.SetSize(Value: longint); begin; end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' i: longint;');
- Add('begin');
- Add(' with TObject.Create do begin');
- Add(' i:=int;');
- Add(' int:=i;');
- Add(' i:=size;');
- Add(' size:=i;');
- Add(' end;');
- Add(' with obj do begin');
- Add(' i:=int;');
- Add(' int:=i;');
- Add(' i:=size;');
- Add(' size:=i;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestClass_WithClassInstDoProperty',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FInt = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- ' this.GetSize = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Value) {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with = $mod.TObject.$create("Create");',
- '$mod.i = $with.FInt;',
- '$with.FInt = $mod.i;',
- '$mod.i = $with.GetSize();',
- '$with.SetSize($mod.i);',
- 'var $with1 = $mod.Obj;',
- '$mod.i = $with1.FInt;',
- '$with1.FInt = $mod.i;',
- '$mod.i = $with1.GetSize();',
- '$with1.SetSize($mod.i);',
- '']));
- end;
- procedure TTestModule.TestClass_WithClassInstDoPropertyWithParams;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' constructor Create;');
- Add(' function GetItems(Index: longint): longint;');
- Add(' procedure SetItems(Index, Value: longint);');
- Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
- Add(' end;');
- Add('constructor TObject.Create; begin end;');
- Add('function tobject.getitems(index: longint): longint; begin; end;');
- Add('procedure tobject.setitems(index, value: longint); begin; end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' i: longint;');
- Add('begin');
- Add(' with TObject.Create do begin');
- Add(' i:=Items[1];');
- Add(' Items[2]:=i;');
- Add(' end;');
- Add(' with obj do begin');
- Add(' i:=Items[3];');
- Add(' Items[4]:=i;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestClass_WithClassInstDoPropertyWithParams',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- ' this.GetItems = function (Index) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with = $mod.TObject.$create("Create");',
- '$mod.i = $with.GetItems(1);',
- '$with.SetItems(2, $mod.i);',
- 'var $with1 = $mod.Obj;',
- '$mod.i = $with1.GetItems(3);',
- '$with1.SetItems(4, $mod.i);',
- '']));
- end;
- procedure TTestModule.TestClass_WithClassInstDoFunc;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' constructor Create;');
- Add(' function GetSize: longint;');
- Add(' procedure SetSize(Value: longint);');
- Add(' end;');
- Add('constructor TObject.Create; begin end;');
- Add('function TObject.GetSize: longint; begin; end;');
- Add('procedure TObject.SetSize(Value: longint); begin; end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' i: longint;');
- Add('begin');
- Add(' with TObject.Create do begin');
- Add(' i:=GetSize;');
- Add(' i:=GetSize();');
- Add(' SetSize(i);');
- Add(' end;');
- Add(' with obj do begin');
- Add(' i:=GetSize;');
- Add(' i:=GetSize();');
- Add(' SetSize(i);');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestClass_WithClassInstDoFunc',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- ' this.GetSize = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Value) {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with = $mod.TObject.$create("Create");',
- '$mod.i = $with.GetSize();',
- '$mod.i = $with.GetSize();',
- '$with.SetSize($mod.i);',
- 'var $with1 = $mod.Obj;',
- '$mod.i = $with1.GetSize();',
- '$mod.i = $with1.GetSize();',
- '$with1.SetSize($mod.i);',
- '']));
- end;
- procedure TTestModule.TestClass_TypeCast;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' Next: TObject;');
- Add(' constructor Create;');
- Add(' end;');
- Add(' TControl = class(TObject)');
- Add(' Arr: array of TObject;');
- Add(' function GetIt(vI: longint = 0): TObject;');
- Add(' end;');
- Add('constructor tobject.create; begin end;');
- Add('function tcontrol.getit(vi: longint = 0): tobject; begin end;');
- Add('var');
- Add(' Obj: tobject;');
- Add('begin');
- Add(' obj:=tcontrol(obj).next;');
- Add(' tcontrol(obj):=nil;');
- Add(' obj:=tcontrol(obj);');
- Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit);');
- Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit());');
- Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit(1));');
- Add(' tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit).arr[2]);');
- Add(' obj:=tcontrol(nil);');
- ConvertProgram;
- CheckSource('TestClass_TypeCast',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Next = null;',
- ' };',
- ' this.$final = function () {',
- ' this.Next = undefined;',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TControl", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.Arr = [];',
- ' };',
- ' this.$final = function () {',
- ' this.Arr = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- ' this.GetIt = function (vI) {',
- ' var Result = null;',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.Obj.Next;',
- '$mod.Obj = null;',
- '$mod.Obj = $mod.Obj;',
- '$mod.Obj = $mod.Obj.GetIt(0);',
- '$mod.Obj = $mod.Obj.GetIt(0);',
- '$mod.Obj = $mod.Obj.GetIt(1);',
- '$mod.Obj = $mod.Obj.GetIt(0).Arr[2];',
- '$mod.Obj = null;',
- '']));
- end;
- procedure TTestModule.TestClass_TypeCastUntypedParam;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class end;');
- Add('procedure ProcA(var A);');
- Add('begin');
- Add(' TObject(A):=nil;');
- Add(' TObject(A):=TObject(A);');
- Add(' if TObject(A)=nil then ;');
- Add(' if nil=TObject(A) then ;');
- Add('end;');
- Add('procedure ProcB(out A);');
- Add('begin');
- Add(' TObject(A):=nil;');
- Add(' TObject(A):=TObject(A);');
- Add(' if TObject(A)=nil then ;');
- Add(' if nil=TObject(A) then ;');
- Add('end;');
- Add('procedure ProcC(const A);');
- Add('begin');
- Add(' if TObject(A)=nil then ;');
- Add(' if nil=TObject(A) then ;');
- Add('end;');
- Add('var o: TObject;');
- Add('begin');
- Add(' ProcA(o);');
- Add(' ProcB(o);');
- Add(' ProcC(o);');
- ConvertProgram;
- CheckSource('TestClass_TypeCastUntypedParam',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.ProcA = function (A) {',
- ' A.set(null);',
- ' A.set(A.get());',
- ' if (A.get() === null);',
- ' if (null === A.get());',
- '};',
- 'this.ProcB = function (A) {',
- ' A.set(null);',
- ' A.set(A.get());',
- ' if (A.get() === null);',
- ' if (null === A.get());',
- '};',
- 'this.ProcC = function (A) {',
- ' if (A === null);',
- ' if (null === A);',
- '};',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ProcA({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.o;',
- ' },',
- ' set: function (v) {',
- ' this.p.o = v;',
- ' }',
- '});',
- '$mod.ProcB({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.o;',
- ' },',
- ' set: function (v) {',
- ' this.p.o = v;',
- ' }',
- '});',
- '$mod.ProcC($mod.o);',
- '']));
- end;
- procedure TTestModule.TestClass_Overloads;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' procedure DoIt;');
- Add(' procedure DoIt(vI: longint);');
- Add(' end;');
- Add('procedure TObject.DoIt;');
- Add('begin');
- Add(' DoIt;');
- Add(' DoIt(1);');
- Add('end;');
- Add('procedure TObject.DoIt(vI: longint); begin end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestClass_Overloads',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' this.DoIt();',
- ' this.DoIt$1(1);',
- ' };',
- ' this.DoIt$1 = function (vI) {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_OverloadsAncestor;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class;');
- Add(' TObject = class');
- Add(' procedure DoIt(vA: longint);');
- Add(' procedure DoIt(vA, vB: longint);');
- Add(' end;');
- Add(' TCar = class;');
- Add(' TCar = class');
- Add(' procedure DoIt(vA: longint);');
- Add(' procedure DoIt(vA, vB: longint);');
- Add(' end;');
- Add('procedure tobject.doit(va: longint);');
- Add('begin');
- Add(' doit(1);');
- Add(' doit(1,2);');
- Add('end;');
- Add('procedure tobject.doit(va, vb: longint); begin end;');
- Add('procedure tcar.doit(va: longint);');
- Add('begin');
- Add(' doit(1);');
- Add(' doit(1,2);');
- Add(' inherited doit(1);');
- Add(' inherited doit(1,2);');
- Add('end;');
- Add('procedure tcar.doit(va, vb: longint); begin end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestClass_OverloadsAncestor',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (vA) {',
- ' this.DoIt(1);',
- ' this.DoIt$1(1,2);',
- ' };',
- ' this.DoIt$1 = function (vA, vB) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TCar", this.TObject, function () {',
- ' this.DoIt$2 = function (vA) {',
- ' this.DoIt$2(1);',
- ' this.DoIt$3(1, 2);',
- ' $mod.TObject.DoIt.call(this, 1);',
- ' $mod.TObject.DoIt$1.call(this, 1, 2);',
- ' };',
- ' this.DoIt$3 = function (vA, vB) {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_OverloadConstructor;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' constructor Create(vA: longint);');
- Add(' constructor Create(vA, vB: longint);');
- Add(' end;');
- Add(' TCar = class');
- Add(' constructor Create(vA: longint);');
- Add(' constructor Create(vA, vB: longint);');
- Add(' end;');
- Add('constructor tobject.create(va: longint);');
- Add('begin');
- Add(' create(1);');
- Add(' create(1,2);');
- Add('end;');
- Add('constructor tobject.create(va, vb: longint); begin end;');
- Add('constructor tcar.create(va: longint);');
- Add('begin');
- Add(' create(1);');
- Add(' create(1,2);');
- Add(' inherited create(1);');
- Add(' inherited create(1,2);');
- Add('end;');
- Add('constructor tcar.create(va, vb: longint); begin end;');
- Add('begin');
- Add(' tobject.create(1);');
- Add(' tobject.create(1,2);');
- Add(' tcar.create(1);');
- Add(' tcar.create(1,2);');
- ConvertProgram;
- CheckSource('TestClass_OverloadConstructor',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function (vA) {',
- ' this.Create(1);',
- ' this.Create$1(1,2);',
- ' return this;',
- ' };',
- ' this.Create$1 = function (vA, vB) {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TCar", this.TObject, function () {',
- ' this.Create$2 = function (vA) {',
- ' this.Create$2(1);',
- ' this.Create$3(1, 2);',
- ' $mod.TObject.Create.call(this, 1);',
- ' $mod.TObject.Create$1.call(this, 1, 2);',
- ' return this;',
- ' };',
- ' this.Create$3 = function (vA, vB) {',
- ' return this;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TObject.$create("Create", [1]);',
- '$mod.TObject.$create("Create$1", [1, 2]);',
- '$mod.TCar.$create("Create$2", [1]);',
- '$mod.TCar.$create("Create$3", [1, 2]);',
- '']));
- end;
- procedure TTestModule.TestClass_OverloadDelphiOverride;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'type',
- ' TObject = class end;',
- ' TBird = class',
- ' function {#a}GetValue: longint; overload; virtual;',
- ' function {#b}GetValue(AValue: longint): longint; overload; virtual;',
- ' end;',
- ' TEagle = class(TBird)',
- ' function {#c}GetValue: longint; overload; override;',
- ' function {#d}GetValue(AValue: longint): longint; overload; override;',
- ' end;',
- 'function TBird.GetValue: longint;',
- 'begin',
- ' if 3={@a}GetValue then ;',
- ' if 4={@b}GetValue(5) then ;',
- 'end;',
- 'function TBird.GetValue(AValue: longint): longint;',
- 'begin',
- 'end;',
- 'function TEagle.GetValue: longint;',
- 'begin',
- ' if 13={@c}GetValue then ;',
- ' if 14={@d}GetValue(15) then ;',
- ' if 15=inherited {@a}GetValue then ;',
- ' if 16=inherited {@b}GetValue(17) then ;',
- 'end;',
- 'function TEagle.GetValue(AValue: longint): longint;',
- 'begin',
- 'end;',
- 'var',
- ' e: TEagle;',
- 'begin',
- ' if 23=e.{@c}GetValue then ;',
- ' if 24=e.{@d}GetValue(25) then ;']);
- ConvertProgram;
- CheckSource('TestClass_OverloadDelphiOverride',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.GetValue = function () {',
- ' var Result = 0;',
- ' if (3 === this.GetValue()) ;',
- ' if (4 === this.GetValue$1(5)) ;',
- ' return Result;',
- ' };',
- ' this.GetValue$1 = function (AValue) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass(this, "TEagle", this.TBird, function () {',
- ' this.GetValue = function () {',
- ' var Result = 0;',
- ' if (13 === this.GetValue()) ;',
- ' if (14 === this.GetValue$1(15)) ;',
- ' if (15 === $mod.TBird.GetValue.call(this)) ;',
- ' if (16 === $mod.TBird.GetValue$1.call(this, 17)) ;',
- ' return Result;',
- ' };',
- ' this.GetValue$1 = function (AValue) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'this.e = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'if (23 === $mod.e.GetValue()) ;',
- 'if (24 === $mod.e.GetValue$1(25)) ;',
- '']));
- end;
- procedure TTestModule.TestClass_ReintroduceVarDelphi;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'type',
- ' TObject = class end;',
- ' TAnimal = class',
- ' public',
- ' {#animal_a}A: longint;',
- ' function {#animal_b}B: longint;',
- ' end;',
- ' TBird = class(TAnimal)',
- ' public',
- ' {#bird_a}A: double;',
- ' {#bird_b}B: boolean;',
- ' end;',
- ' TEagle = class(TBird)',
- ' public',
- ' function {#eagle_a}A: boolean;',
- ' {#eagle_b}B: double;',
- ' end;',
- 'function TAnimal.B: longint;',
- 'begin',
- 'end;',
- 'function TEagle.A: boolean;',
- 'begin',
- ' {@eagle_b}B:=3.3;',
- ' {@eagle_a}A();',
- ' TBird(Self).{@bird_b}B:=true;',
- ' TAnimal(Self).{@animal_a}A:=17;',
- ' inherited {@bird_b}B:=inherited {bird_a}A>1;', // Delphi allows only inherited <functionname>
- 'end;',
- 'var',
- ' e: TEagle;',
- 'begin',
- ' e.{@eagle_b}B:=5.3;',
- ' if e.{@eagle_a}A then ;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_ReintroduceVarDelphi',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TAnimal", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.A = 0;',
- ' };',
- ' this.B = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TAnimal, function () {',
- ' this.$init = function () {',
- ' $mod.TAnimal.$init.call(this);',
- ' this.A$1 = 0.0;',
- ' this.B$1 = false;',
- ' };',
- '});',
- 'rtl.createClass(this, "TEagle", this.TBird, function () {',
- ' this.$init = function () {',
- ' $mod.TBird.$init.call(this);',
- ' this.B$2 = 0.0;',
- ' };',
- ' this.A$2 = function () {',
- ' var Result = false;',
- ' this.B$2 = 3.3;',
- ' this.A$2();',
- ' this.B$1 = true;',
- ' this.A = 17;',
- ' this.B$1 = this.A$1 > 1;',
- ' return Result;',
- ' };',
- '});',
- 'this.e = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.e.B$2 = 5.3;',
- 'if ($mod.e.A$2()) ;',
- '']));
- end;
- procedure TTestModule.TestClass_ReintroducedVar;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' strict private');
- Add(' Some: longint;');
- Add(' end;');
- Add(' TMobile = class');
- Add(' strict private');
- Add(' Some: string;');
- Add(' end;');
- Add(' TCar = class(tmobile)');
- Add(' procedure Some;');
- Add(' procedure Some(vA: longint);');
- Add(' end;');
- Add('procedure tcar.some;');
- Add('begin');
- Add(' Some;');
- Add(' Some(1);');
- Add('end;');
- Add('procedure tcar.some(va: longint); begin end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestClass_ReintroducedVar',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Some = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TMobile", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.Some$1 = "";',
- ' };',
- '});',
- 'rtl.createClass(this, "TCar", this.TMobile, function () {',
- ' this.Some$2 = function () {',
- ' this.Some$2();',
- ' this.Some$3(1);',
- ' };',
- ' this.Some$3 = function (vA) {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_RaiseDescendant;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' constructor Create(Msg: string);',
- ' end;',
- ' Exception = class',
- ' end;',
- ' EConvertError = class(Exception)',
- ' end;',
- 'constructor TObject.Create(Msg: string); begin end;',
- 'function AssertConv(Msg: string = ''def''): EConvertError; begin end;',
- 'begin',
- ' raise Exception.Create(''Bar1'');',
- ' raise EConvertError.Create(''Bar2'');',
- ' raise AssertConv(''Bar2'');',
- ' raise AssertConv;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_RaiseDescendant',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function (Msg) {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "Exception", this.TObject, function () {',
- '});',
- 'rtl.createClass(this, "EConvertError", this.Exception, function () {',
- '});',
- 'this.AssertConv = function (Msg) {',
- ' var Result = null;',
- ' return Result;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- 'throw $mod.Exception.$create("Create",["Bar1"]);',
- 'throw $mod.EConvertError.$create("Create",["Bar2"]);',
- 'throw $mod.AssertConv("Bar2");',
- 'throw $mod.AssertConv("def");',
- '']));
- end;
- procedure TTestModule.TestClass_ExternalMethod;
- begin
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- 'type',
- ' TObject = class',
- ' public',
- ' procedure Intern; external name ''$DoIntern'';',
- ' end;',
- '']),
- LinesToStr([
- '']));
- StartUnit(true);
- Add('interface');
- Add('uses unit2;');
- Add('type');
- Add(' TCar = class(TObject)');
- Add(' public');
- Add(' procedure Intern2; external name ''$DoIntern2'';');
- Add(' procedure DoIt;');
- Add(' end;');
- Add('implementation');
- Add('procedure tcar.doit;');
- Add('begin');
- Add(' Intern;');
- Add(' Intern();');
- Add(' Intern2;');
- Add(' Intern2();');
- Add('end;');
- Add('var Obj: TCar;');
- Add('begin');
- Add(' obj.intern;');
- Add(' obj.intern();');
- Add(' obj.intern2;');
- Add(' obj.intern2();');
- Add(' obj.doit;');
- Add(' obj.doit();');
- Add(' with obj do begin');
- Add(' Intern;');
- Add(' Intern();');
- Add(' Intern2;');
- Add(' Intern2();');
- Add(' end;');
- ConvertUnit;
- CheckSource('TestClass_ExternalMethod',
- LinesToStr([
- 'var $impl = $mod.$impl;',
- 'rtl.createClass(this, "TCar", pas.unit2.TObject, function () {',
- ' this.DoIt = function () {',
- ' this.$DoIntern();',
- ' this.$DoIntern();',
- ' this.$DoIntern2();',
- ' this.$DoIntern2();',
- ' };',
- ' });',
- '']),
- LinesToStr([ // this.$init
- '$impl.Obj.$DoIntern();',
- '$impl.Obj.$DoIntern();',
- '$impl.Obj.$DoIntern2();',
- '$impl.Obj.$DoIntern2();',
- '$impl.Obj.DoIt();',
- '$impl.Obj.DoIt();',
- 'var $with = $impl.Obj;',
- '$with.$DoIntern();',
- '$with.$DoIntern();',
- '$with.$DoIntern2();',
- '$with.$DoIntern2();',
- '']),
- LinesToStr([ // implementation
- '$impl.Obj = null;',
- '']) );
- end;
- procedure TTestModule.TestClass_ExternalVirtualNameMismatchFail;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' procedure DoIt; virtual; external name ''Foo'';');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError('Virtual method name must match external',
- nVirtualMethodNameMustMatchExternal);
- ConvertProgram;
- end;
- procedure TTestModule.TestClass_ExternalOverrideFail;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' procedure DoIt; virtual; external name ''DoIt'';');
- Add(' end;');
- Add(' TCar = class');
- Add(' procedure DoIt; override; external name ''DoIt'';');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError('Invalid procedure modifier override,external',
- nInvalidXModifierY);
- ConvertProgram;
- end;
- procedure TTestModule.TestClass_ExternalVar;
- begin
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- '{$modeswitch externalclass}',
- 'type',
- ' TObject = class',
- ' public',
- ' Intern: longint external name ''$Intern'';',
- ' Bracket: longint external name ''["A B"]'';',
- ' end;',
- '']),
- LinesToStr([
- '']));
- StartUnit(true);
- Add([
- 'interface',
- 'uses unit2;',
- '{$modeswitch externalclass}',
- 'type',
- ' TCar = class(tobject)',
- ' public',
- ' Intern2: longint external name ''$Intern2'';',
- ' procedure DoIt;',
- ' end;',
- 'implementation',
- 'procedure tcar.doit;',
- 'begin',
- ' Intern:=Intern+1;',
- ' Intern2:=Intern2+2;',
- ' Bracket:=Bracket+3;',
- 'end;',
- 'var Obj: TCar;',
- 'begin',
- ' obj.intern:=obj.intern+1;',
- ' obj.intern2:=obj.intern2+2;',
- ' obj.Bracket:=obj.Bracket+3;',
- ' with obj do begin',
- ' intern:=intern+1;',
- ' intern2:=intern2+2;',
- ' Bracket:=Bracket+3;',
- ' end;']);
- ConvertUnit;
- CheckSource('TestClass_ExternalVar',
- LinesToStr([
- 'var $impl = $mod.$impl;',
- 'rtl.createClass(this, "TCar", pas.unit2.TObject, function () {',
- ' this.DoIt = function () {',
- ' this.$Intern = this.$Intern + 1;',
- ' this.$Intern2 = this.$Intern2 + 2;',
- ' this["A B"] = this["A B"] + 3;',
- ' };',
- ' });',
- '']),
- LinesToStr([
- '$impl.Obj.$Intern = $impl.Obj.$Intern + 1;',
- '$impl.Obj.$Intern2 = $impl.Obj.$Intern2 + 2;',
- '$impl.Obj["A B"] = $impl.Obj["A B"] + 3;',
- 'var $with = $impl.Obj;',
- '$with.$Intern = $with.$Intern + 1;',
- '$with.$Intern2 = $with.$Intern2 + 2;',
- '$with["A B"] = $with["A B"] + 3;',
- '']),
- LinesToStr([ // implementation
- '$impl.Obj = null;',
- '']));
- end;
- procedure TTestModule.TestClass_Const;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' TClass = class of TObject;',
- ' TObject = class',
- ' public',
- ' const cI: integer = 3;',
- ' procedure DoIt;',
- ' class procedure DoMore;',
- ' end;',
- 'procedure tobject.doit;',
- 'begin',
- ' if cI=4 then;',
- ' if 5=cI then;',
- ' if Self.cI=6 then;',
- ' if 7=Self.cI then;',
- ' with Self do begin',
- ' if cI=11 then;',
- ' if 12=cI then;',
- ' end;',
- 'end;',
- 'class procedure tobject.domore;',
- 'begin',
- ' if cI=8 then;',
- ' if Self.cI=9 then;',
- ' if 10=cI then;',
- ' if 11=Self.cI then;',
- ' with Self do begin',
- ' if cI=13 then;',
- ' if 14=cI then;',
- ' end;',
- 'end;',
- 'var',
- ' Obj: TObject;',
- ' Cla: TClass;',
- 'begin',
- ' if TObject.cI=21 then ;',
- ' if Obj.cI=22 then ;',
- ' if Cla.cI=23 then ;',
- ' with obj do if ci=24 then;',
- ' with TObject do if ci=25 then;',
- ' with Cla do if ci=26 then;']);
- ConvertProgram;
- CheckSource('TestClass_Const',
- LinesToStr([
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.cI = 3;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' if (this.cI === 4) ;',
- ' if (5 === this.cI) ;',
- ' if (this.cI === 6) ;',
- ' if (7 === this.cI) ;',
- ' if (this.cI === 11) ;',
- ' if (12 === this.cI) ;',
- ' };',
- ' this.DoMore = function () {',
- ' if (this.cI === 8) ;',
- ' if (this.cI === 9) ;',
- ' if (10 === this.cI) ;',
- ' if (11 === this.cI) ;',
- ' if (this.cI === 13) ;',
- ' if (14 === this.cI) ;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.Cla = null;',
- '']),
- LinesToStr([
- 'if ($mod.TObject.cI === 21) ;',
- 'if ($mod.Obj.cI === 22) ;',
- 'if ($mod.Cla.cI === 23) ;',
- 'var $with = $mod.Obj;',
- 'if ($with.cI === 24) ;',
- 'var $with1 = $mod.TObject;',
- 'if ($with1.cI === 25) ;',
- 'var $with2 = $mod.Cla;',
- 'if ($with2.cI === 26) ;',
- '']));
- end;
- procedure TTestModule.TestClass_ConstEnum;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (red,blue);',
- ' TObject = class',
- ' end;',
- ' TAnimal = class',
- ' public',
- ' type TSubEnum = (light,dark);',
- ' const a = high(TEnum);',
- ' const b = high(TSubEnum);',
- ' end;',
- ' TBird = class(TAnimal)',
- ' public',
- ' const c = high(TEnum);',
- ' const d = high(TSubEnum);',
- ' end;',
- ' TAnt = class',
- ' public',
- ' const e = high(TEnum);',
- ' const f = high(TBird.TSubEnum);',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClass_ConstEnum',
- LinesToStr([
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TAnimal", this.TObject, function () {',
- ' this.TSubEnum = {',
- ' "0": "light",',
- ' light: 0,',
- ' "1": "dark",',
- ' dark: 1',
- ' };',
- ' this.a = $mod.TEnum.blue;',
- ' this.b = this.TSubEnum.dark;',
- '});',
- 'rtl.createClass(this, "TBird", this.TAnimal, function () {',
- ' this.c = $mod.TEnum.blue;',
- ' this.d = this.TSubEnum.dark;',
- '});',
- 'rtl.createClass(this, "TAnt", this.TObject, function () {',
- ' this.e = $mod.TEnum.blue;',
- ' this.f = $mod.TAnimal.TSubEnum.dark;',
- '});',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestClass_LocalConstDuplicate_Prg;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' const cI: longint = 3;',
- ' procedure Fly;',
- ' procedure Run;',
- ' end;',
- ' TBird = class',
- ' procedure Go;',
- ' end;',
- 'procedure tobject.fly;',
- 'const cI: word = 4;',
- 'begin',
- ' if cI=Self.cI then ;',
- 'end;',
- 'procedure tobject.run;',
- 'const cI: word = 5;',
- 'begin',
- ' if cI=Self.cI then ;',
- 'end;',
- 'procedure tbird.go;',
- 'const cI: word = 6;',
- 'begin',
- ' if cI=Self.cI then ;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClass_LocalConstDuplicate_Prg',
- LinesToStr([
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.cI = 3;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var cI$1 = 4;',
- ' this.Fly = function () {',
- ' if (cI$1 === this.cI) ;',
- ' };',
- ' var cI$2 = 5;',
- ' this.Run = function () {',
- ' if (cI$2 === this.cI) ;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' var cI$3 = 6;',
- ' this.Go = function () {',
- ' if (cI$3 === this.cI) ;',
- ' };',
- '});',
- '']),
- LinesToStr([
- '']));
- end;
- procedure TTestModule.TestClass_LocalConstDuplicate_Unit;
- begin
- StartUnit(false);
- Add([
- 'interface',
- 'type',
- ' TObject = class',
- ' const cI: longint = 3;',
- ' procedure Fly;',
- ' procedure Run;',
- ' end;',
- ' TBird = class',
- ' procedure Go;',
- ' end;',
- 'implementation',
- 'procedure tobject.fly;',
- 'const cI: word = 4;',
- 'begin',
- ' if cI=Self.cI then ;',
- 'end;',
- 'procedure tobject.run;',
- 'const cI: word = 5;',
- 'begin',
- ' if cI=Self.cI then ;',
- 'end;',
- 'procedure tbird.go;',
- 'const cI: word = 6;',
- 'begin',
- ' if cI=Self.cI then ;',
- 'end;',
- '']);
- ConvertUnit;
- CheckSource('TestClass_LocalConstDuplicate_Unit',
- LinesToStr([
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.cI = 3;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var cI$1 = 4;',
- ' this.Fly = function () {',
- ' if (cI$1 === this.cI) ;',
- ' };',
- ' var cI$2 = 5;',
- ' this.Run = function () {',
- ' if (cI$2 === this.cI) ;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' var cI$3 = 6;',
- ' this.Go = function () {',
- ' if (cI$3 === this.cI) ;',
- ' };',
- '});',
- '']),
- '',
- '');
- end;
- procedure TTestModule.TestClass_LocalVarSelfFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- 'constructor tobject.create;',
- 'var self: longint;',
- 'begin',
- 'end',
- 'begin',
- '']);
- SetExpectedPasResolverError('Duplicate identifier "self" at (0)',nDuplicateIdentifier);
- ConvertProgram;
- end;
- procedure TTestModule.TestClass_ArgSelfFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure DoIt(Self: longint);',
- ' end;',
- 'procedure tobject.doit(self: longint);',
- 'begin',
- 'end',
- 'begin',
- '']);
- SetExpectedPasResolverError('Duplicate identifier "Self" at test1.pp(5,24)',nDuplicateIdentifier);
- ConvertProgram;
- end;
- procedure TTestModule.TestClass_NestedProcSelf;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' Key: longint;',
- ' class var State: longint;',
- ' procedure DoIt;',
- ' function GetSize: longint; virtual; abstract;',
- ' procedure SetSize(Value: longint); virtual; abstract;',
- ' property Size: longint read GetSize write SetSize;',
- ' end;',
- 'procedure tobject.doit;',
- ' procedure Sub;',
- ' begin',
- ' key:=key+2;',
- ' self.key:=self.key+3;',
- ' state:=state+4;',
- ' self.state:=self.state+5;',
- ' tobject.state:=tobject.state+6;',
- ' size:=size+7;',
- ' self.size:=self.size+8;',
- ' end;',
- 'begin',
- ' sub;',
- ' key:=key+12;',
- ' self.key:=self.key+13;',
- ' state:=state+14;',
- ' self.state:=self.state+15;',
- ' tobject.state:=tobject.state+16;',
- ' size:=size+17;',
- ' self.size:=self.size+18;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClass_NestedProcSelf',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.State = 0;',
- ' this.$init = function () {',
- ' this.Key = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' var $Self = this;',
- ' function Sub() {',
- ' $Self.Key = $Self.Key + 2;',
- ' $Self.Key = $Self.Key + 3;',
- ' $mod.TObject.State = $Self.State + 4;',
- ' $mod.TObject.State = $Self.State + 5;',
- ' $mod.TObject.State = $mod.TObject.State + 6;',
- ' $Self.SetSize($Self.GetSize() + 7);',
- ' $Self.SetSize($Self.GetSize() + 8);',
- ' };',
- ' Sub();',
- ' this.Key = this.Key + 12;',
- ' $Self.Key = $Self.Key + 13;',
- ' $mod.TObject.State = this.State + 14;',
- ' $mod.TObject.State = $Self.State + 15;',
- ' $mod.TObject.State = $mod.TObject.State + 16;',
- ' this.SetSize(this.GetSize() + 17);',
- ' $Self.SetSize($Self.GetSize() + 18);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_NestedProcSelf2;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' Key: longint;',
- ' class var State: longint;',
- ' function GetSize: longint; virtual; abstract;',
- ' procedure SetSize(Value: longint); virtual; abstract;',
- ' property Size: longint read GetSize write SetSize;',
- ' end;',
- ' TBird = class',
- ' procedure DoIt;',
- ' end;',
- 'procedure tbird.doit;',
- ' procedure Sub;',
- ' begin',
- ' key:=key+2;',
- ' self.key:=self.key+3;',
- ' state:=state+4;',
- ' self.state:=self.state+5;',
- ' tobject.state:=tobject.state+6;',
- ' size:=size+7;',
- ' self.size:=self.size+8;',
- ' end;',
- 'begin',
- ' sub;',
- ' key:=key+12;',
- ' self.key:=self.key+13;',
- ' state:=state+14;',
- ' self.state:=self.state+15;',
- ' tobject.state:=tobject.state+16;',
- ' size:=size+17;',
- ' self.size:=self.size+18;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClass_NestedProcSelf2',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.State = 0;',
- ' this.$init = function () {',
- ' this.Key = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' var $Self = this;',
- ' function Sub() {',
- ' $Self.Key = $Self.Key + 2;',
- ' $Self.Key = $Self.Key + 3;',
- ' $mod.TObject.State = $Self.State + 4;',
- ' $mod.TObject.State = $Self.State + 5;',
- ' $mod.TObject.State = $mod.TObject.State + 6;',
- ' $Self.SetSize($Self.GetSize() + 7);',
- ' $Self.SetSize($Self.GetSize() + 8);',
- ' };',
- ' Sub();',
- ' this.Key = this.Key + 12;',
- ' $Self.Key = $Self.Key + 13;',
- ' $mod.TObject.State = this.State + 14;',
- ' $mod.TObject.State = $Self.State + 15;',
- ' $mod.TObject.State = $mod.TObject.State + 16;',
- ' this.SetSize(this.GetSize() + 17);',
- ' $Self.SetSize($Self.GetSize() + 18);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_NestedProcClassSelf;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' class var State: longint;',
- ' class procedure DoIt;',
- ' class function GetSize: longint; virtual; abstract;',
- ' class procedure SetSize(Value: longint); virtual; abstract;',
- ' class property Size: longint read GetSize write SetSize;',
- ' end;',
- 'class procedure tobject.doit;',
- ' procedure Sub;',
- ' begin',
- ' state:=state+2;',
- ' self.state:=self.state+3;',
- ' tobject.state:=tobject.state+4;',
- ' size:=size+5;',
- ' self.size:=self.size+6;',
- ' tobject.size:=tobject.size+7;',
- ' end;',
- 'begin',
- ' sub;',
- ' state:=state+12;',
- ' self.state:=self.state+13;',
- ' tobject.state:=tobject.state+14;',
- ' size:=size+15;',
- ' self.size:=self.size+16;',
- ' tobject.size:=tobject.size+17;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClass_NestedProcClassSelf',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.State = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' var $Self = this;',
- ' function Sub() {',
- ' $mod.TObject.State = $Self.State + 2;',
- ' $mod.TObject.State = $Self.State + 3;',
- ' $mod.TObject.State = $mod.TObject.State + 4;',
- ' $Self.SetSize($Self.GetSize() + 5);',
- ' $Self.SetSize($Self.GetSize() + 6);',
- ' $mod.TObject.SetSize($mod.TObject.GetSize() + 7);',
- ' };',
- ' Sub();',
- ' $mod.TObject.State = this.State + 12;',
- ' $mod.TObject.State = $Self.State + 13;',
- ' $mod.TObject.State = $mod.TObject.State + 14;',
- ' this.SetSize(this.GetSize() + 15);',
- ' $Self.SetSize($Self.GetSize() + 16);',
- ' $mod.TObject.SetSize($mod.TObject.GetSize() + 17);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_NestedProcCallInherited;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' function DoIt(k: boolean): longint; virtual;',
- ' end;',
- ' TBird = class',
- ' function DoIt(k: boolean): longint; override;',
- ' end;',
- 'function tobject.doit(k: boolean): longint;',
- 'begin',
- 'end;',
- 'function tbird.doit(k: boolean): longint;',
- ' procedure Sub;',
- ' begin',
- ' inherited DoIt(true);',
- //' if inherited DoIt(false)=4 then ;',
- ' end;',
- 'begin',
- ' Sub;',
- ' inherited;',
- ' inherited DoIt(true);',
- //' if inherited DoIt(false)=14 then ;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClass_NestedProcCallInherited',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (k) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function (k) {',
- ' var $Self = this;',
- ' var Result = 0;',
- ' function Sub() {',
- ' $mod.TObject.DoIt.call($Self, true);',
- ' };',
- ' Sub();',
- ' $mod.TObject.DoIt.apply(this, arguments);',
- ' $mod.TObject.DoIt.call(this, true);',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_TObjectFree;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' Obj: tobject;',
- ' procedure Free;',
- ' procedure Release;',
- ' end;',
- 'procedure tobject.free;',
- 'begin',
- 'end;',
- 'procedure tobject.release;',
- 'begin',
- ' free;',
- ' if true then free;',
- 'end;',
- 'function DoIt(o: tobject): tobject;',
- 'var l: tobject;',
- 'begin',
- ' o.free;',
- ' o.free();',
- ' l.free;',
- ' l.free();',
- ' o.obj.free;',
- ' o.obj.free();',
- ' with o do obj.free;',
- ' with o do obj.free();',
- ' result.Free;',
- ' result.Free();',
- 'end;',
- 'var o: tobject;',
- ' a: array of tobject;',
- 'begin',
- ' o.free;',
- ' o.obj.free;',
- ' a[1+2].free;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_TObjectFree',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Obj = null;',
- ' };',
- ' this.$final = function () {',
- ' this.Obj = undefined;',
- ' };',
- ' this.Free = function () {',
- ' };',
- ' this.Release = function () {',
- ' this.Free();',
- ' if (true) this.Free();',
- ' };',
- '});',
- 'this.DoIt = function (o) {',
- ' var Result = null;',
- ' var l = null;',
- ' o = rtl.freeLoc(o);',
- ' o = rtl.freeLoc(o);',
- ' l = rtl.freeLoc(l);',
- ' l = rtl.freeLoc(l);',
- ' rtl.free(o, "Obj");',
- ' rtl.free(o, "Obj");',
- ' rtl.free(o, "Obj");',
- ' rtl.free(o, "Obj");',
- ' Result = rtl.freeLoc(Result);',
- ' Result = rtl.freeLoc(Result);',
- ' return Result;',
- '};',
- 'this.o = null;',
- 'this.a = [];',
- '']),
- LinesToStr([ // $mod.$main
- 'rtl.free($mod, "o");',
- 'rtl.free($mod.o, "Obj");',
- 'rtl.free($mod.a, 1 + 2);',
- '']));
- end;
- procedure TTestModule.TestClass_TObjectFree_VarArg;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' Obj: tobject;',
- ' procedure Free;',
- ' end;',
- 'procedure tobject.free;',
- 'begin',
- 'end;',
- 'procedure DoIt(var o: tobject);',
- 'begin',
- ' o.free;',
- ' o.free();',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClass_TObjectFree_VarArg',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Obj = null;',
- ' };',
- ' this.$final = function () {',
- ' this.Obj = undefined;',
- ' };',
- ' this.Free = function () {',
- ' };',
- '});',
- 'this.DoIt = function (o) {',
- ' o.set(rtl.freeLoc(o.get()));',
- ' o.set(rtl.freeLoc(o.get()));',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_TObjectFreeNewInstance;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' procedure Free;',
- ' end;',
- 'constructor TObject.Create; begin end;',
- 'procedure tobject.free; begin end;',
- 'begin',
- ' with tobject.create do free;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_TObjectFreeNewInstance',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- ' this.Free = function () {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- 'var $with = $mod.TObject.$create("Create");',
- '$with=rtl.freeLoc($with);',
- '']));
- end;
- procedure TTestModule.TestClass_TObjectFreeLowerCase;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' destructor Destroy;',
- ' procedure Free;',
- ' end;',
- 'destructor TObject.Destroy; begin end;',
- 'procedure tobject.free; begin end;',
- 'var o: tobject;',
- 'begin',
- ' o.free;',
- '']);
- Converter.UseLowerCase:=true;
- ConvertProgram;
- CheckSource('TestClass_TObjectFreeLowerCase',
- LinesToStr([ // statements
- 'rtl.createClass(this, "tobject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.tObjectDestroy = "destroy";',
- ' this.destroy = function () {',
- ' };',
- ' this.free = function () {',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'rtl.free($mod, "o");',
- '']));
- end;
- procedure TTestModule.TestClass_TObjectFreeFunctionFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure Free;',
- ' function GetObj: tobject; virtual; abstract;',
- ' end;',
- 'procedure tobject.free;',
- 'begin',
- 'end;',
- 'var o: tobject;',
- 'begin',
- ' o.getobj.free;',
- '']);
- SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
- ConvertProgram;
- end;
- procedure TTestModule.TestClass_TObjectFreePropertyFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure Free;',
- ' FObj: TObject;',
- ' property Obj: tobject read FObj write FObj;',
- ' end;',
- 'procedure tobject.free;',
- 'begin',
- 'end;',
- 'var o: tobject;',
- 'begin',
- ' o.obj.free;',
- '']);
- SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
- ConvertProgram;
- end;
- procedure TTestModule.TestClass_ForIn;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- ' TItem = TObject;',
- ' TEnumerator = class',
- ' FCurrent: TItem;',
- ' property Current: TItem read FCurrent;',
- ' function MoveNext: boolean;',
- ' end;',
- ' TBird = class',
- ' function GetEnumerator: TEnumerator;',
- ' end;',
- 'function TEnumerator.MoveNext: boolean;',
- 'begin',
- 'end;',
- 'function TBird.GetEnumerator: TEnumerator;',
- 'begin',
- 'end;',
- 'var',
- ' b: TBird;',
- ' i, i2: TItem;',
- 'begin',
- ' for i in b do i2:=i;']);
- ConvertProgram;
- CheckSource('TestClass_ForIn',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TEnumerator", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FCurrent = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FCurrent = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- ' this.MoveNext = function () {',
- ' var Result = false;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.GetEnumerator = function () {',
- ' var Result = null;',
- ' return Result;',
- ' };',
- '});',
- 'this.b = null;',
- 'this.i = null;',
- 'this.i2 = null;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $in = $mod.b.GetEnumerator();',
- 'try {',
- ' while ($in.MoveNext()){',
- ' $mod.i = $in.FCurrent;',
- ' $mod.i2 = $mod.i;',
- ' }',
- '} finally {',
- ' $in = rtl.freeLoc($in)',
- '};',
- '']));
- end;
- procedure TTestModule.TestClass_DispatchMessage;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' {$DispatchField DispInt}',
- ' procedure Dispatch(var Msg); virtual; abstract;',
- ' {$DispatchStrField DispStr}',
- ' procedure DispatchStr(var Msg); virtual; abstract;',
- ' end;',
- ' THopMsg = record',
- ' DispInt: longint;',
- ' end;',
- ' TPutMsg = record',
- ' DispStr: string;',
- ' end;',
- ' TBird = class',
- ' procedure Fly(var Msg); virtual; abstract; message 2;',
- ' procedure Run; overload; virtual; abstract;',
- ' procedure Run(var Msg); overload; message ''Fast'';',
- ' procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
- ' procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
- ' end;',
- 'procedure TBird.Run(var Msg);',
- 'begin',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClass_Message',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.recNewT(this, "THopMsg", function () {',
- ' this.DispInt = 0;',
- ' this.$eq = function (b) {',
- ' return this.DispInt === b.DispInt;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.DispInt = s.DispInt;',
- ' return this;',
- ' };',
- '});',
- 'rtl.recNewT(this, "TPutMsg", function () {',
- ' this.DispStr = "";',
- ' this.$eq = function (b) {',
- ' return this.DispStr === b.DispStr;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.DispStr = s.DispStr;',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Run$1 = function (Msg) {',
- ' };',
- ' this.$msgint = {',
- ' "2": "Fly",',
- ' "3": "Hop"',
- ' };',
- ' this.$msgstr = {',
- ' Fast: "Run$1",',
- ' foo: "Put"',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_Message_DuplicateIntFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure Fly(var Msg); virtual; abstract; message 3;',
- ' procedure Run(var Msg); virtual; abstract; message 1+2;',
- ' end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Duplicate message id "3" at test1.pp(5,56)',nDuplicateMessageIdXAtY);
- ConvertProgram;
- end;
- procedure TTestModule.TestClass_DispatchMessage_WrongFieldNameFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' {$dispatchfield Msg}',
- ' procedure Dispatch(var Msg); virtual; abstract;',
- ' end;',
- ' TFlyMsg = record',
- ' FlyId: longint;',
- ' end;',
- ' TBird = class',
- ' procedure Fly(var Msg: TFlyMsg); virtual; abstract; message 3;',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckHint(mtWarning,nDispatchRequiresX,'Dispatch requires record field "Msg"');
- end;
- procedure TTestModule.TestClassOf_Create;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' constructor Create;');
- Add(' end;');
- Add(' TClass = class of TObject;');
- Add('constructor tobject.create; begin end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' C: tclass;');
- Add('begin');
- Add(' obj:=C.create;');
- Add(' with c do obj:=create;');
- ConvertProgram;
- CheckSource('TestClassOf_Create',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.C.$create("Create");',
- 'var $with = $mod.C;',
- '$mod.Obj = $with.$create("Create");',
- '']));
- end;
- procedure TTestModule.TestClassOf_Call;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' class procedure DoIt;');
- Add(' end;');
- Add(' TClass = class of TObject;');
- Add('class procedure tobject.doit; begin end;');
- Add('var');
- Add(' C: tclass;');
- Add('begin');
- Add(' c.doit;');
- Add(' with c do doit;');
- ConvertProgram;
- CheckSource('TestClassOf_Call',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' };',
- '});',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.C.DoIt();',
- 'var $with = $mod.C;',
- '$with.DoIt();',
- '']));
- end;
- procedure TTestModule.TestClassOf_Assign;
- begin
- StartProgram(false);
- Add('type');
- Add(' TClass = class of TObject;');
- Add(' TObject = class');
- Add(' ClassType: TClass; ');
- Add(' end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' C: tclass;');
- Add('begin');
- Add(' c:=nil;');
- Add(' c:=obj.classtype;');
- ConvertProgram;
- CheckSource('TestClassOf_Assign',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.ClassType = null;',
- ' };',
- ' this.$final = function () {',
- ' this.ClassType = undefined;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.C = null;',
- '$mod.C = $mod.Obj.ClassType;',
- '']));
- end;
- procedure TTestModule.TestClassOf_Is;
- begin
- StartProgram(false);
- Add('type');
- Add(' TClass = class of TObject;');
- Add(' TObject = class');
- Add(' end;');
- Add(' TCar = class');
- Add(' end;');
- Add(' TCars = class of TCar;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' C: tclass;');
- Add(' Cars: tcars;');
- Add('begin');
- Add(' if c is tcar then ;');
- Add(' if c is tcars then ;');
- ConvertProgram;
- CheckSource('TestClassOf_Is',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TCar", this.TObject, function () {',
- '});',
- 'this.Obj = null;',
- 'this.C = null;',
- 'this.Cars = null;'
- ]),
- LinesToStr([ // $mod.$main
- 'if(rtl.is($mod.C,$mod.TCar));',
- 'if(rtl.is($mod.C,$mod.TCar));',
- '']));
- end;
- procedure TTestModule.TestClassOf_Compare;
- begin
- StartProgram(false);
- Add('type');
- Add(' TClass = class of TObject;');
- Add(' TObject = class');
- Add(' ClassType: TClass; ');
- Add(' end;');
- Add('var');
- Add(' b: boolean;');
- Add(' Obj: tobject;');
- Add(' C: tclass;');
- Add('begin');
- Add(' b:=c=nil;');
- Add(' b:=nil=c;');
- Add(' b:=c=obj.classtype;');
- Add(' b:=obj.classtype=c;');
- Add(' b:=c=TObject;');
- Add(' b:=TObject=c;');
- Add(' b:=c<>nil;');
- Add(' b:=nil<>c;');
- Add(' b:=c<>obj.classtype;');
- Add(' b:=obj.classtype<>c;');
- Add(' b:=c<>TObject;');
- Add(' b:=TObject<>c;');
- ConvertProgram;
- CheckSource('TestClassOf_Compare',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.ClassType = null;',
- ' };',
- ' this.$final = function () {',
- ' this.ClassType = undefined;',
- ' };',
- '});',
- 'this.b = false;',
- 'this.Obj = null;',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.b = $mod.C === null;',
- '$mod.b = null === $mod.C;',
- '$mod.b = $mod.C === $mod.Obj.ClassType;',
- '$mod.b = $mod.Obj.ClassType === $mod.C;',
- '$mod.b = $mod.C === $mod.TObject;',
- '$mod.b = $mod.TObject === $mod.C;',
- '$mod.b = $mod.C !== null;',
- '$mod.b = null !== $mod.C;',
- '$mod.b = $mod.C !== $mod.Obj.ClassType;',
- '$mod.b = $mod.Obj.ClassType !== $mod.C;',
- '$mod.b = $mod.C !== $mod.TObject;',
- '$mod.b = $mod.TObject !== $mod.C;',
- '']));
- end;
- procedure TTestModule.TestClassOf_ClassVar;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' class var id: longint;');
- Add(' end;');
- Add(' TClass = class of TObject;');
- Add('var');
- Add(' C: tclass;');
- Add('begin');
- Add(' C.id:=C.id;');
- ConvertProgram;
- CheckSource('TestClassOf_ClassVar',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.id = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.TObject.id = $mod.C.id;',
- '']));
- end;
- procedure TTestModule.TestClassOf_ClassMethod;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' class function DoIt(i: longint = 0): longint;');
- Add(' end;');
- Add(' TClass = class of TObject;');
- Add('class function tobject.doit(i: longint = 0): longint; begin end;');
- Add('var');
- Add(' i: longint;');
- Add(' C: tclass;');
- Add('begin');
- Add(' C.DoIt;');
- Add(' C.DoIt();');
- Add(' i:=C.DoIt;');
- Add(' i:=C.DoIt();');
- ConvertProgram;
- CheckSource('TestClassOf_ClassMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (i) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'this.i = 0;',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.C.DoIt(0);',
- '$mod.C.DoIt(0);',
- '$mod.i = $mod.C.DoIt(0);',
- '$mod.i = $mod.C.DoIt(0);',
- '']));
- end;
- procedure TTestModule.TestClassOf_ClassProperty;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' class var FA: longint;',
- ' class function GetA: longint;',
- ' class procedure SetA(Value: longint);',
- ' class property pA: longint read fa write fa;',
- ' class property pB: longint read geta write seta;',
- ' end;',
- ' TObjectClass = class of tobject;',
- 'class function tobject.geta: longint; begin end;',
- 'class procedure tobject.seta(value: longint); begin end;',
- 'var',
- ' b: boolean;',
- ' Obj: tobject;',
- ' Cla: tobjectclass;',
- 'begin',
- ' obj.pa:=obj.pa;',
- ' obj.pb:=obj.pb;',
- ' b:=obj.pa=4;',
- ' b:=obj.pb=obj.pb;',
- ' b:=5=obj.pa;',
- ' cla.pa:=6;',
- ' cla.pa:=cla.pa;',
- ' cla.pb:=cla.pb;',
- ' b:=cla.pa=7;',
- ' b:=cla.pb=cla.pb;',
- ' b:=8=cla.pa;',
- ' tobject.pa:=9;',
- ' tobject.pb:=tobject.pb;',
- ' b:=tobject.pa=10;',
- ' b:=11=tobject.pa;',
- '']);
- ConvertProgram;
- CheckSource('TestClassOf_ClassProperty',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.FA = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetA = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetA = function (Value) {',
- ' };',
- '});',
- 'this.b = false;',
- 'this.Obj = null;',
- 'this.Cla = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.TObject.FA = $mod.Obj.FA;',
- '$mod.Obj.$class.SetA($mod.Obj.$class.GetA());',
- '$mod.b = $mod.Obj.FA === 4;',
- '$mod.b = $mod.Obj.$class.GetA() === $mod.Obj.$class.GetA();',
- '$mod.b = 5 === $mod.Obj.FA;',
- '$mod.TObject.FA = 6;',
- '$mod.TObject.FA = $mod.Cla.FA;',
- '$mod.Cla.SetA($mod.Cla.GetA());',
- '$mod.b = $mod.Cla.FA === 7;',
- '$mod.b = $mod.Cla.GetA() === $mod.Cla.GetA();',
- '$mod.b = 8 === $mod.Cla.FA;',
- '$mod.TObject.FA = 9;',
- '$mod.TObject.SetA($mod.TObject.GetA());',
- '$mod.b = $mod.TObject.FA === 10;',
- '$mod.b = 11 === $mod.TObject.FA;',
- '']));
- end;
- procedure TTestModule.TestClassOf_ClassMethodSelf;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' class var GlobalId: longint;');
- Add(' class procedure ProcA;');
- Add(' end;');
- Add('class procedure tobject.proca;');
- Add('var b: boolean;');
- Add('begin');
- Add(' b:=self=nil;');
- Add(' b:=self.globalid=3;');
- Add(' b:=4=self.globalid;');
- Add(' self.globalid:=5;');
- Add(' self.proca;');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestClassOf_ClassMethodSelf',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.GlobalId = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.ProcA = function () {',
- ' var b = false;',
- ' b = this === null;',
- ' b = this.GlobalId === 3;',
- ' b = 4 === this.GlobalId;',
- ' $mod.TObject.GlobalId = 5;',
- ' this.ProcA();',
- ' };',
- '});'
- ]),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassOf_TypeCast;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' class procedure {#TObject_DoIt}DoIt;');
- Add(' end;');
- Add(' TClass = class of TObject;');
- Add(' TMobile = class');
- Add(' class procedure {#TMobile_DoIt}DoIt;');
- Add(' end;');
- Add(' TMobileClass = class of TMobile;');
- Add(' TCar = class(TMobile)');
- Add(' class procedure {#TCar_DoIt}DoIt;');
- Add(' end;');
- Add(' TCarClass = class of TCar;');
- Add('class procedure TObject.DoIt;');
- Add('begin');
- Add(' TClass(Self).{@TObject_DoIt}DoIt;');
- Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
- Add('end;');
- Add('class procedure TMobile.DoIt;');
- Add('begin');
- Add(' TClass(Self).{@TObject_DoIt}DoIt;');
- Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
- Add(' TCarClass(Self).{@TCar_DoIt}DoIt;');
- Add('end;');
- Add('class procedure TCar.DoIt; begin end;');
- Add('var');
- Add(' ObjC: TClass;');
- Add(' MobileC: TMobileClass;');
- Add(' CarC: TCarClass;');
- Add('begin');
- Add(' ObjC.{@TObject_DoIt}DoIt;');
- Add(' MobileC.{@TMobile_DoIt}DoIt;');
- Add(' CarC.{@TCar_DoIt}DoIt;');
- Add(' TClass(ObjC).{@TObject_DoIt}DoIt;');
- Add(' TMobileClass(ObjC).{@TMobile_DoIt}DoIt;');
- Add(' TCarClass(ObjC).{@TCar_DoIt}DoIt;');
- Add(' TClass(MobileC).{@TObject_DoIt}DoIt;');
- Add(' TMobileClass(MobileC).{@TMobile_DoIt}DoIt;');
- Add(' TCarClass(MobileC).{@TCar_DoIt}DoIt;');
- Add(' TClass(CarC).{@TObject_DoIt}DoIt;');
- Add(' TMobileClass(CarC).{@TMobile_DoIt}DoIt;');
- Add(' TCarClass(CarC).{@TCar_DoIt}DoIt;');
- ConvertProgram;
- CheckSource('TestClassOf_TypeCast',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' this.DoIt();',
- ' this.DoIt$1();',
- ' };',
- '});',
- 'rtl.createClass(this, "TMobile", this.TObject, function () {',
- ' this.DoIt$1 = function () {',
- ' this.DoIt();',
- ' this.DoIt$1();',
- ' this.DoIt$2();',
- ' };',
- '});',
- 'rtl.createClass(this, "TCar", this.TMobile, function () {',
- ' this.DoIt$2 = function () {',
- ' };',
- '});',
- 'this.ObjC = null;',
- 'this.MobileC = null;',
- 'this.CarC = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ObjC.DoIt();',
- '$mod.MobileC.DoIt$1();',
- '$mod.CarC.DoIt$2();',
- '$mod.ObjC.DoIt();',
- '$mod.ObjC.DoIt$1();',
- '$mod.ObjC.DoIt$2();',
- '$mod.MobileC.DoIt();',
- '$mod.MobileC.DoIt$1();',
- '$mod.MobileC.DoIt$2();',
- '$mod.CarC.DoIt();',
- '$mod.CarC.DoIt$1();',
- '$mod.CarC.DoIt$2();',
- '']));
- end;
- procedure TTestModule.TestClassOf_ImplicitFunctionCall;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' function CurNow: longint; ');
- Add(' class function Now: longint; ');
- Add(' end;');
- Add('function TObject.CurNow: longint; begin end;');
- Add('class function TObject.Now: longint; begin end;');
- Add('var');
- Add(' Obj: tobject;');
- Add(' vI: longint;');
- Add('begin');
- Add(' obj.curnow;');
- Add(' vi:=obj.curnow;');
- Add(' tobject.now;');
- Add(' vi:=tobject.now;');
- ConvertProgram;
- CheckSource('TestClassOf_ImplicitFunctionCall',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.CurNow = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.Now = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.vI = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Obj.CurNow();',
- '$mod.vI = $mod.Obj.CurNow();',
- '$mod.TObject.Now();',
- '$mod.vI = $mod.TObject.Now();',
- '']));
- end;
- procedure TTestModule.TestClassOf_Const;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' end;',
- ' TBird = TObject;',
- ' TBirds = class of TBird;',
- ' TEagles = TBirds;',
- ' THawk = class(TBird);',
- 'const',
- ' Hawk: TEagles = THawk;',
- ' DefaultBirdClasses : Array [1..2] of TEagles = (',
- ' TBird,',
- ' THawk',
- ' );',
- 'begin']);
- ConvertProgram;
- CheckSource('TestClassOf_Const',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "THawk", this.TObject, function () {',
- '});',
- 'this.Hawk = this.THawk;',
- 'this.DefaultBirdClasses = [this.TObject, this.THawk];',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestNestedClass_Alias;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' type TNested = type longint;',
- ' end;',
- 'type TAlias = type tobject.tnested;',
- 'var i: tobject.tnested = 3;',
- 'var j: TAlias = 4;',
- 'begin',
- ' if typeinfo(TAlias)=nil then ;',
- ' if typeinfo(tobject.tnested)=nil then ;',
- '']);
- ConvertProgram;
- CheckSource('TestNestedClass_Alias',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' $mod.$rtti.$inherited("TObject.TNested", rtl.longint, {});',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.$rtti.$inherited("TAlias", this.$rtti["TObject.TNested"], {});',
- 'this.i = 3;',
- 'this.j = 4;',
- '']),
- LinesToStr([ // $mod.$main
- 'if ($mod.$rtti["TAlias"] === null) ;',
- 'if ($mod.$rtti["TObject.TNested"] === null) ;',
- '']));
- end;
- procedure TTestModule.TestNestedClass_Record;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' type TPoint = record',
- ' x,y: byte;',
- ' end;',
- ' procedure DoIt(t: TPoint);',
- ' end;',
- 'procedure tobject.DoIt(t: TPoint);',
- 'var p: TPoint;',
- 'begin',
- ' t.x:=t.y;',
- ' p:=t;',
- 'end;',
- 'var',
- ' p: tobject.tpoint = (x:2; y:4);',
- ' o: TObject;',
- 'begin',
- ' p:=p;',
- ' o.doit(p);',
- '']);
- ConvertProgram;
- CheckSource('TestNestedClass_Record',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- ' var $r = $mod.$rtti.$Record("TObject.TPoint", {});',
- ' $r.addField("x", rtl.byte);',
- ' $r.addField("y", rtl.byte);',
- ' });',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (t) {',
- ' var p = this.TPoint.$new();',
- ' t.x = t.y;',
- ' p.$assign(t);',
- ' };',
- '});',
- 'this.p = this.TObject.TPoint.$clone({',
- ' x: 2,',
- ' y: 4',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p.$assign($mod.p);',
- '$mod.o.DoIt($mod.TObject.TPoint.$clone($mod.p));',
- '']));
- end;
- procedure TTestModule.TestNestedClass_Class;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- ' TBird = class',
- ' type TLeg = class',
- ' FId: longint;',
- ' constructor Create;',
- ' function Create(i: longint): TLeg;',
- ' end;',
- ' function DoIt(b: TBird): Tleg;',
- ' end;',
- 'constructor tbird.tleg.create;',
- 'begin',
- ' FId:=3;',
- 'end;',
- 'function tbird.tleg.Create(i: longint): TLeg;',
- 'begin',
- ' Create;',
- ' Result:=TLeg.Create;',
- ' Result:=TBird.TLeg.Create;',
- ' Result:=Create(3);',
- ' FId:=i;',
- 'end;',
- 'function tbird.DoIt(b: tbird): tleg;',
- 'begin',
- ' Result.Create;',
- ' Result:=TLeg.Create;',
- ' Result:=TBird.TLeg.Create;',
- ' Result:=Result.Create(3);',
- 'end;',
- 'var',
- ' b: Tbird.tleg;',
- 'begin',
- ' b.Create;',
- ' b:=TBird.TLeg.Create;',
- ' b:=b.Create(3);',
- '']);
- ConvertProgram;
- CheckSource('TestNestedClass_Class',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.createClass(this, "TLeg", $mod.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FId = 0;',
- ' };',
- ' this.Create = function () {',
- ' this.FId = 3;',
- ' return this;',
- ' };',
- ' this.Create$1 = function (i) {',
- ' var Result = null;',
- ' this.Create();',
- ' Result = $mod.TBird.TLeg.$create("Create");',
- ' Result = $mod.TBird.TLeg.$create("Create");',
- ' Result = this.Create$1(3);',
- ' this.FId = i;',
- ' return Result;',
- ' };',
- ' }, "TBird.TLeg");',
- ' this.DoIt = function (b) {',
- ' var Result = null;',
- ' Result.Create();',
- ' Result = this.TLeg.$create("Create");',
- ' Result = $mod.TBird.TLeg.$create("Create");',
- ' Result = Result.Create$1(3);',
- ' return Result;',
- ' };',
- '});',
- 'this.b = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.b.Create();',
- '$mod.b = $mod.TBird.TLeg.$create("Create");',
- '$mod.b = $mod.b.Create$1(3);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_Var;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObj''',
- ' Id: longint external name ''$Id'';',
- ' B: longint;',
- ' end;',
- 'var Obj: TExtA;',
- 'begin',
- ' obj.id:=obj.id+1;',
- ' obj.B:=obj.B+1;']);
- ConvertProgram;
- CheckSource('TestExternalClass_Var',
- LinesToStr([ // statements
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Obj.$Id = $mod.Obj.$Id + 1;',
- '$mod.Obj.B = $mod.Obj.B + 1;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_Const;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObj''',
- ' const Two: longint = 2;',
- ' const Three = 3;',
- ' const Id: longint;',
- ' end;',
- ' TExtB = class external name ''ExtB''',
- ' A: TExtA;',
- ' end;',
- 'var',
- ' A: texta;',
- ' B: textb;',
- ' i: longint;',
- 'begin',
- ' i:=a.two;',
- ' i:=texta.two;',
- ' i:=a.three;',
- ' i:=texta.three;',
- ' i:=a.id;',
- ' i:=texta.id;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_Const',
- LinesToStr([ // statements
- 'this.A = null;',
- 'this.B = null;',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.i = 2;',
- '$mod.i = 2;',
- '$mod.i = 3;',
- '$mod.i = 3;',
- '$mod.i = $mod.A.Id;',
- '$mod.i = ExtObj.Id;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_Dollar;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''$''',
- ' Id: longint external name ''$'';',
- ' function Bla(i: longint): longint; external name ''$'';',
- ' end;',
- 'function dollar(k: longint): longint; external name ''$'';',
- 'var Obj: TExtA;',
- 'begin',
- ' dollar(1);',
- ' obj.id:=obj.id+2;',
- ' obj.Bla(3);',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_Dollar',
- LinesToStr([ // statements
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$(1);',
- '$mod.Obj.$ = $mod.Obj.$ + 2;',
- '$mod.Obj.$(3);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_DuplicateVarFail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' Id: longint external name ''$Id'';');
- Add(' end;');
- Add(' TExtB = class external ''lib'' name ''ExtB''(TExtA)');
- Add(' Id: longint;');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError('Duplicate identifier "Id" at test1.pp(6,5)',nDuplicateIdentifier);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_Method;
- begin
- StartProgram(false);
- Add(['{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObj''',
- ' procedure DoIt(Id: longint = 1); external name ''$Execute'';',
- ' procedure DoSome(Id: longint = 1);',
- ' end;',
- 'var Obj: texta;',
- 'begin',
- ' obj.doit;',
- ' obj.doit();',
- ' obj.doit(2);',
- ' with obj do begin',
- ' doit;',
- ' doit();',
- ' doit(3);',
- ' end;']);
- ConvertProgram;
- CheckSource('TestExternalClass_Method',
- LinesToStr([ // statements
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Obj.$Execute(1);',
- '$mod.Obj.$Execute(1);',
- '$mod.Obj.$Execute(2);',
- 'var $with = $mod.Obj;',
- '$with.$Execute(1);',
- '$with.$Execute(1);',
- '$with.$Execute(3);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ClassMethod;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObj''',
- ' class procedure DoIt(Id: longint = 1); external name ''$Execute'';',
- ' end;',
- ' TExtB = TExtA;',
- 'var p: Pointer;',
- 'begin',
- ' texta.doit;',
- ' texta.doit();',
- ' texta.doit(2);',
- ' p:[email protected];',
- ' with texta do begin',
- ' doit;',
- ' doit();',
- ' doit(3);',
- ' p:=@DoIt;',
- ' end;',
- ' textb.doit;',
- ' textb.doit();',
- ' textb.doit(4);',
- ' with textb do begin',
- ' doit;',
- ' doit();',
- ' doit(5);',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_ClassMethod',
- LinesToStr([ // statements
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'ExtObj.$Execute(1);',
- 'ExtObj.$Execute(1);',
- 'ExtObj.$Execute(2);',
- '$mod.p = rtl.createCallback(ExtObj, "$Execute");',
- 'ExtObj.$Execute(1);',
- 'ExtObj.$Execute(1);',
- 'ExtObj.$Execute(3);',
- '$mod.p = rtl.createCallback(ExtObj, "$Execute");',
- 'ExtObj.$Execute(1);',
- 'ExtObj.$Execute(1);',
- 'ExtObj.$Execute(4);',
- 'ExtObj.$Execute(1);',
- 'ExtObj.$Execute(1);',
- 'ExtObj.$Execute(5);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ClassMethodStatic;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObj''',
- ' class procedure DoIt(Id: longint = 1); static;',
- ' end;',
- 'var p: Pointer;',
- 'begin',
- ' texta.doit;',
- ' texta.doit();',
- ' texta.doit(2);',
- ' p:[email protected];',
- ' with texta do begin',
- ' doit;',
- ' doit();',
- ' doit(3);',
- ' p:=@DoIt;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_ClassMethodStatic',
- LinesToStr([ // statements
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'ExtObj.DoIt(1);',
- 'ExtObj.DoIt(1);',
- 'ExtObj.DoIt(2);',
- '$mod.p = ExtObj.DoIt;',
- 'ExtObj.DoIt(1);',
- 'ExtObj.DoIt(1);',
- 'ExtObj.DoIt(3);',
- '$mod.p = ExtObj.DoIt;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_FunctionResultInTypeCast;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TBird = class external name ''Array''',
- ' end;',
- 'function GetPtr: Pointer;',
- 'begin',
- 'end;',
- 'procedure Write(const p);',
- 'begin',
- 'end;',
- 'procedure WriteLn; varargs;',
- 'begin',
- 'end;',
- 'begin',
- ' if TBird(GetPtr)=nil then ;',
- ' Write(GetPtr);',
- ' WriteLn(GetPtr);',
- ' Write(TBird(GetPtr));',
- ' WriteLn(TBird(GetPtr));',
- '']);
- ConvertProgram;
- CheckSource('TestFunctionResultInTypeCast',
- LinesToStr([ // statements
- 'this.GetPtr = function () {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.Write = function (p) {',
- '};',
- 'this.WriteLn = function () {',
- '};',
- '']),
- LinesToStr([
- 'if ($mod.GetPtr() === null) ;',
- '$mod.Write($mod.GetPtr());',
- '$mod.WriteLn($mod.GetPtr());',
- '$mod.Write($mod.GetPtr());',
- '$mod.WriteLn($mod.GetPtr());',
- '']));
- end;
- procedure TTestModule.TestExternalClass_NonExternalOverride;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObjA''',
- ' procedure ProcA; virtual;',
- ' procedure ProcB; virtual;',
- ' end;',
- ' TExtB = class external name ''ExtObjB'' (TExtA)',
- ' end;',
- ' TExtC = class (TExtB)',
- ' procedure ProcA; override;',
- ' end;',
- 'procedure TExtC.ProcA;',
- 'begin',
- ' ProcA;',
- ' Self.ProcA;',
- ' ProcB;',
- ' Self.ProcB;',
- 'end;',
- 'var',
- ' A: texta;',
- ' B: textb;',
- ' C: textc;',
- 'begin',
- ' a.proca;',
- ' b.proca;',
- ' c.proca;']);
- ConvertProgram;
- CheckSource('TestExternalClass_NonExternalOverride',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TExtC", ExtObjB, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.ProcA = function () {',
- ' this.ProcA();',
- ' this.ProcA();',
- ' this.ProcB();',
- ' this.ProcB();',
- ' };',
- '});',
- 'this.A = null;',
- 'this.B = null;',
- 'this.C = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A.ProcA();',
- '$mod.B.ProcA();',
- '$mod.C.ProcA();',
- '']));
- end;
- procedure TTestModule.TestExternalClass_OverloadHint;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObjA''',
- ' procedure DoIt;',
- ' procedure DoIt(i: longint);',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckResolverUnexpectedHints(true);
- CheckSource('TestExternalClass_OverloadHint',
- LinesToStr([ // statements
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestExternalClass_SameNamePublishedProperty;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' JSwiper = class external name ''Swiper''',
- ' constructor New;',
- ' end;',
- ' TObject = class',
- ' private',
- ' FSwiper: JSwiper;',
- ' published',
- ' property Swiper: JSwiper read FSwiper write FSwiper;',
- ' end;',
- 'begin',
- ' JSwiper.new;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_SameNamePublishedProperty',
- LinesToStr([ // statements
- 'this.$rtti.$ExtClass("JSwiper", {',
- ' jsclass: "Swiper"',
- '});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FSwiper = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FSwiper = undefined;',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty("Swiper", 0, $mod.$rtti["JSwiper"], "FSwiper", "FSwiper");',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- 'new Swiper();',
- '']));
- end;
- procedure TTestModule.TestExternalClass_Property;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' function getYear: longint;',
- ' procedure setYear(Value: longint);',
- ' property Year: longint read getyear write setyear;',
- ' end;',
- ' TExtB = class (TExtA)',
- ' procedure OtherSetYear(Value: longint);',
- ' property year write othersetyear;',
- ' end;',
- 'procedure textb.othersetyear(value: longint);',
- 'begin',
- ' setYear(Value+4);',
- 'end;',
- 'var',
- ' A: texta;',
- ' B: textb;',
- 'begin',
- ' a.year:=a.year+1;',
- ' b.year:=b.year+2;']);
- ConvertProgram;
- CheckSource('TestExternalClass_NonExternalOverride',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TExtB", ExtA, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.OtherSetYear = function (Value) {',
- ' this.setYear(Value+4);',
- ' };',
- '});',
- 'this.A = null;',
- 'this.B = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A.setYear($mod.A.getYear()+1);',
- '$mod.B.OtherSetYear($mod.B.getYear()+2);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_PropertyDate;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' end;',
- ' TExtB = class (TExtA)',
- ' FDate: string;',
- ' property Date: string read FDate write FDate;',
- ' property ExtA: string read FDate write FDate;',
- ' end;',
- ' {$M+}',
- ' TObject = class',
- ' FDate: string;',
- ' published',
- ' property Date: string read FDate write FDate;',
- ' property ExtA: string read FDate write FDate;',
- ' end;',
- 'var',
- ' B: textb;',
- ' o: TObject;',
- 'begin',
- ' b.date:=b.exta;',
- ' o.date:=o.exta;']);
- ConvertProgram;
- CheckSource('TestExternalClass_PropertyDate',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TExtB", ExtA, "", function () {',
- ' this.$init = function () {',
- ' this.FDate = "";',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FDate = "";',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addField("FDate", rtl.string);',
- ' $r.addProperty("Date", 0, rtl.string, "FDate", "FDate");',
- ' $r.addProperty("ExtA", 0, rtl.string, "FDate", "FDate");',
- '});',
- 'this.B = null;',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.B.FDate = $mod.B.FDate;',
- '$mod.o.FDate = $mod.o.FDate;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ClassProperty;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' class function getYear: longint;');
- Add(' class procedure setYear(Value: longint);');
- Add(' class property Year: longint read getyear write setyear;');
- Add(' end;');
- Add(' TExtB = class (TExtA)');
- Add(' class function GetCentury: longint;');
- Add(' class procedure SetCentury(Value: longint);');
- Add(' class property Century: longint read getcentury write setcentury;');
- Add(' end;');
- Add('class function textb.getcentury: longint;');
- Add('begin');
- Add('end;');
- Add('class procedure textb.setcentury(value: longint);');
- Add('begin');
- Add(' setyear(value+11);');
- Add(' texta.year:=texta.year+12;');
- Add(' year:=year+13;');
- Add(' textb.century:=textb.century+14;');
- Add(' century:=century+15;');
- Add('end;');
- Add('var');
- Add(' A: texta;');
- Add(' B: textb;');
- Add('begin');
- Add(' texta.year:=texta.year+1;');
- Add(' textb.year:=textb.year+2;');
- Add(' TextA.year:=TextA.year+3;');
- Add(' b.year:=b.year+4;');
- Add(' textb.century:=textb.century+5;');
- Add(' b.century:=b.century+6;');
- ConvertProgram;
- CheckSource('TestExternalClass_ClassProperty',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TExtB", ExtA, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetCentury = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetCentury = function (Value) {',
- ' this.setYear(Value + 11);',
- ' ExtA.setYear(ExtA.getYear() + 12);',
- ' this.setYear(this.getYear() + 13);',
- ' $mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 14);',
- ' this.SetCentury(this.GetCentury() + 15);',
- ' };',
- '});',
- 'this.A = null;',
- 'this.B = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'ExtA.setYear(ExtA.getYear() + 1);',
- '$mod.TExtB.setYear($mod.TExtB.getYear() + 2);',
- 'ExtA.setYear(ExtA.getYear() + 3);',
- '$mod.B.setYear($mod.B.getYear() + 4);',
- '$mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 5);',
- '$mod.B.$class.SetCentury($mod.B.$class.GetCentury() + 6);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ClassOf;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' procedure ProcA; virtual;');
- Add(' procedure ProcB; virtual;');
- Add(' end;');
- Add(' TExtAClass = class of TExtA;');
- Add(' TExtB = class external name ''ExtB'' (TExtA)');
- Add(' end;');
- Add(' TExtBClass = class of TExtB;');
- Add(' TExtC = class (TExtB)');
- Add(' procedure ProcA; override;');
- Add(' end;');
- Add(' TExtCClass = class of TExtC;');
- Add('procedure TExtC.ProcA; begin end;');
- Add('var');
- Add(' A: texta; ClA: TExtAClass;');
- Add(' B: textb; ClB: TExtBClass;');
- Add(' C: textc; ClC: TExtCClass;');
- Add('begin');
- Add(' ClA:=texta;');
- Add(' ClA:=textb;');
- Add(' ClA:=textc;');
- Add(' ClB:=textb;');
- Add(' ClB:=textc;');
- Add(' ClC:=textc;');
- ConvertProgram;
- CheckSource('TestExternalClass_ClassOf',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TExtC", ExtB, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.ProcA = function () {',
- ' };',
- '});',
- 'this.A = null;',
- 'this.ClA = null;',
- 'this.B = null;',
- 'this.ClB = null;',
- 'this.C = null;',
- 'this.ClC = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ClA = ExtA;',
- '$mod.ClA = ExtB;',
- '$mod.ClA = $mod.TExtC;',
- '$mod.ClB = ExtB;',
- '$mod.ClB = $mod.TExtC;',
- '$mod.ClC = $mod.TExtC;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ClassOtherUnit;
- begin
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' class var Id: longint;',
- ' end;',
- '']),
- '');
- StartUnit(true);
- Add('interface');
- Add('uses unit2;');
- Add('implementation');
- Add('begin');
- Add(' unit2.texta.id:=unit2.texta.id+1;');
- ConvertUnit;
- CheckSource('TestExternalClass_ClassOtherUnit',
- LinesToStr([
- '']),
- LinesToStr([
- 'ExtA.Id = ExtA.Id + 1;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_Is;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' end;',
- ' TExtAClass = class of TExtA;',
- ' TExtB = class external name ''ExtB'' (TExtA)',
- ' end;',
- ' TExtBClass = class of TExtB;',
- ' TExtC = class (TExtB)',
- ' end;',
- ' TExtCClass = class of TExtC;',
- 'var',
- ' A: texta; ClA: TExtAClass;',
- ' B: textb; ClB: TExtBClass;',
- ' C: textc; ClC: TExtCClass;',
- 'begin',
- ' if a is textb then ;',
- ' if a is textc then ;',
- ' if b is textc then ;',
- ' if cla is textb then ;',
- ' if cla is textc then ;',
- ' if clb is textc then ;',
- ' try',
- ' except',
- ' on TExtA do ;',
- ' on e: TExtB do ;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_Is',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TExtC", ExtB, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.A = null;',
- 'this.ClA = null;',
- 'this.B = null;',
- 'this.ClB = null;',
- 'this.C = null;',
- 'this.ClC = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'if (rtl.isExt($mod.A, ExtB)) ;',
- 'if ($mod.TExtC.isPrototypeOf($mod.A)) ;',
- 'if ($mod.TExtC.isPrototypeOf($mod.B)) ;',
- 'if (rtl.isExt($mod.ClA, ExtB)) ;',
- 'if (rtl.is($mod.ClA, $mod.TExtC)) ;',
- 'if (rtl.is($mod.ClB, $mod.TExtC)) ;',
- 'try {} catch ($e) {',
- ' if (rtl.isExt($e,ExtA)) {}',
- ' else if (rtl.isExt($e,ExtB)) {',
- ' var e = $e;',
- ' } else throw $e',
- '};',
- '']));
- end;
- procedure TTestModule.TestExternalClass_As;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' end;');
- Add(' TExtB = class external name ''ExtB'' (TExtA)');
- Add(' end;');
- Add(' TExtC = class (TExtB)');
- Add(' end;');
- Add('var');
- Add(' A: texta;');
- Add(' B: textb;');
- Add(' C: textc;');
- Add('begin');
- Add(' b:=a as textb;');
- Add(' c:=a as textc;');
- Add(' c:=b as textc;');
- ConvertProgram;
- CheckSource('TestExternalClass_Is',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TExtC", ExtB, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.A = null;',
- 'this.B = null;',
- 'this.C = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.B = rtl.asExt($mod.A, ExtB);',
- '$mod.C = rtl.as($mod.A, $mod.TExtC);',
- '$mod.C = rtl.as($mod.B, $mod.TExtC);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_DestructorFail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' destructor Free;');
- Add(' end;');
- SetExpectedPasResolverError('Pascal element not supported: destructor',
- nPasElementNotSupported);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_New;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' constructor New;',
- ' constructor New(i: longint; j: longint = 2);',
- ' end;',
- 'var',
- ' A: texta;',
- 'begin',
- ' a:=texta.new;',
- ' a:=texta(texta.new);',
- ' a:=texta.new();',
- ' a:=texta.new(1);',
- ' with texta do begin',
- ' a:=new;',
- ' a:=new();',
- ' a:=new(2);',
- ' end;',
- ' a:=test1.texta.new;',
- ' a:=test1.texta.new();',
- ' a:=test1.texta.new(3);',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_New',
- LinesToStr([ // statements
- 'this.A = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A = new ExtA();',
- '$mod.A = new ExtA();',
- '$mod.A = new ExtA();',
- '$mod.A = new ExtA(1,2);',
- '$mod.A = new ExtA();',
- '$mod.A = new ExtA();',
- '$mod.A = new ExtA(2,2);',
- '$mod.A = new ExtA();',
- '$mod.A = new ExtA();',
- '$mod.A = new ExtA(3,2);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ClassOf_New;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtAClass = class of TExtA;');
- Add(' TExtA = class external name ''ExtA''');
- Add(' C: TExtAClass;');
- Add(' constructor New;');
- Add(' end;');
- Add('var');
- Add(' A: texta;');
- Add(' C: textaclass;');
- Add('begin');
- Add(' a:=c.new;');
- Add(' a:=c.new();');
- Add(' with C do begin');
- Add(' a:=new;');
- Add(' a:=new();');
- Add(' end;');
- Add(' a:=test1.c.new;');
- Add(' a:=test1.c.new();');
- Add(' a:=A.c.new();');
- ConvertProgram;
- CheckSource('TestExternalClass_ClassOf_New',
- LinesToStr([ // statements
- 'this.A = null;',
- 'this.C = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A = new $mod.C();',
- '$mod.A = new $mod.C();',
- 'var $with = $mod.C;',
- '$mod.A = new $with();',
- '$mod.A = new $with();',
- '$mod.A = new $mod.C();',
- '$mod.A = new $mod.C();',
- '$mod.A = new $mod.A.C();',
- '']));
- end;
- procedure TTestModule.TestExternalClass_FuncClassOf_New;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtAClass = class of TExtA;',
- ' TExtA = class external name ''ExtA''',
- ' constructor New;',
- ' end;',
- 'function GetCreator: TExtAClass;',
- 'begin',
- ' Result:=TExtA;',
- 'end;',
- 'var',
- ' A: texta;',
- 'begin',
- ' a:=getcreator.new;',
- ' a:=getcreator().new;',
- ' a:=getcreator().new();',
- ' a:=getcreator.new();',
- ' with getcreator do begin',
- ' a:=new;',
- ' a:=new();',
- ' end;']);
- ConvertProgram;
- CheckSource('TestExternalClass_FuncClassOf_New',
- LinesToStr([ // statements
- 'this.GetCreator = function () {',
- ' var Result = null;',
- ' Result = ExtA;',
- ' return Result;',
- '};',
- 'this.A = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A = new ($mod.GetCreator())();',
- '$mod.A = new ($mod.GetCreator())();',
- '$mod.A = new ($mod.GetCreator())();',
- '$mod.A = new ($mod.GetCreator())();',
- 'var $with = $mod.GetCreator();',
- '$mod.A = new $with();',
- '$mod.A = new $with();',
- '']));
- end;
- procedure TTestModule.TestExternalClass_New_PasClassFail;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' constructor New;',
- ' end;',
- ' TBird = class(TExtA)',
- ' end;',
- 'begin',
- ' TBird.new;',
- '']);
- SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_New_PasClassBracketsFail;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' constructor New;',
- ' end;',
- ' TBird = class(TExtA)',
- ' end;',
- 'begin',
- ' TBird.new();',
- '']);
- SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_NewExtName;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' constructor New; external name ''Other'';',
- ' constructor New(i: longint; j: longint = 2); external name ''A.B'';',
- ' end;',
- 'var',
- ' A: texta;',
- 'begin',
- ' a:=texta.new;',
- ' a:=texta(texta.new);',
- ' a:=texta.new();',
- ' a:=texta.new(1);',
- ' with texta do begin',
- ' a:=new;',
- ' a:=new();',
- ' a:=new(2);',
- ' end;',
- ' a:=test1.texta.new;',
- ' a:=test1.texta.new();',
- ' a:=test1.texta.new(3);',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_NewExtName',
- LinesToStr([ // statements
- 'this.A = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A = new Other();',
- '$mod.A = new Other();',
- '$mod.A = new Other();',
- '$mod.A = new A.B(1,2);',
- '$mod.A = new Other();',
- '$mod.A = new Other();',
- '$mod.A = new A.B(2,2);',
- '$mod.A = new Other();',
- '$mod.A = new Other();',
- '$mod.A = new A.B(3,2);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_Constructor;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' constructor Create;',
- ' constructor Create(i: longint; j: longint = 2);',
- ' end;',
- 'var',
- ' A: texta;',
- 'begin',
- ' a:=texta.create;',
- ' a:=texta(texta.create);',
- ' a:=texta.create();',
- ' a:=texta.create(1);',
- ' with texta do begin',
- ' a:=create;',
- ' a:=create();',
- ' a:=create(2);',
- ' end;',
- ' a:=test1.texta.create;',
- ' a:=test1.texta.create();',
- ' a:=test1.texta.create(3);',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_Constructor',
- LinesToStr([ // statements
- 'this.A = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A = new ExtA.Create();',
- '$mod.A = new ExtA.Create();',
- '$mod.A = new ExtA.Create();',
- '$mod.A = new ExtA.Create(1,2);',
- '$mod.A = new ExtA.Create();',
- '$mod.A = new ExtA.Create();',
- '$mod.A = new ExtA.Create(2,2);',
- '$mod.A = new ExtA.Create();',
- '$mod.A = new ExtA.Create();',
- '$mod.A = new ExtA.Create(3,2);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ConstructorBrackets;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtA''',
- ' constructor Create; external name ''{}'';',
- ' end;',
- 'var',
- ' A: texta;',
- 'begin',
- ' a:=texta.create;',
- ' a:=texta(texta.create);',
- ' a:=texta.create();',
- ' with texta do begin',
- ' a:=create;',
- ' a:=create();',
- ' end;',
- ' a:=test1.texta.create;',
- ' a:=test1.texta.create();',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_ConstructorBrackets',
- LinesToStr([ // statements
- 'this.A = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A = {};',
- '$mod.A = {};',
- '$mod.A = {};',
- '$mod.A = {};',
- '$mod.A = {};',
- '$mod.A = {};',
- '$mod.A = {};',
- '']));
- end;
- procedure TTestModule.TestExternalClass_LocalConstSameName;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' constructor New;');
- Add(' end;');
- Add('function DoIt: longint;');
- Add('const ExtA: longint = 3;');
- Add('begin');
- Add(' Result:=ExtA;');
- Add('end;');
- Add('var');
- Add(' A: texta;');
- Add('begin');
- Add(' a:=texta.new;');
- ConvertProgram;
- CheckSource('TestExternalClass_LocalConstSameName',
- LinesToStr([ // statements
- 'var ExtA$1 = 3;',
- 'this.DoIt = function () {',
- ' var Result = 0;',
- ' Result = ExtA$1;',
- ' return Result;',
- '};',
- 'this.A = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.A = new ExtA();',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ReintroduceOverload;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' procedure DoIt;');
- Add(' end;');
- Add(' TMyA = class(TExtA)');
- Add(' procedure DoIt;');
- Add(' end;');
- Add('procedure TMyA.DoIt; begin end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestExternalClass_ReintroduceOverload',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TMyA", ExtA, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt$1 = function () {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestExternalClass_Inherited;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' procedure DoIt(i: longint = 1); virtual;');
- Add(' procedure DoSome(j: longint = 2);');
- Add(' end;');
- Add(' TExtB = class external name ''ExtB''(TExtA)');
- Add(' end;');
- Add(' TMyC = class(TExtB)');
- Add(' procedure DoIt(i: longint = 1); override;');
- Add(' procedure DoSome(j: longint = 2); reintroduce;');
- Add(' end;');
- Add('procedure TMyC.DoIt(i: longint);');
- Add('begin');
- Add(' inherited;');
- Add(' inherited DoIt;');
- Add(' inherited DoIt();');
- Add(' inherited DoIt(3);');
- Add(' inherited DoSome;');
- Add(' inherited DoSome();');
- Add(' inherited DoSome(4);');
- Add('end;');
- Add('procedure TMyC.DoSome(j: longint);');
- Add('begin');
- Add(' inherited;');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestExternalClass_ReintroduceOverload',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TMyC", ExtB, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (i) {',
- ' ExtB.DoIt.apply(this, arguments);',
- ' ExtB.DoIt.call(this, 1);',
- ' ExtB.DoIt.call(this, 1);',
- ' ExtB.DoIt.call(this, 3);',
- ' ExtB.DoSome.call(this, 2);',
- ' ExtB.DoSome.call(this, 2);',
- ' ExtB.DoSome.call(this, 4);',
- ' };',
- ' this.DoSome$1 = function (j) {',
- ' ExtB.DoSome.apply(this, arguments);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestExternalClass_PascalAncestorFail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TObject = class');
- Add(' end;');
- Add(' TExtA = class external name ''ExtA''(TObject)');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError('Ancestor "TObject" is not external',nAncestorIsNotExternal);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_NewInstance;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' end;');
- Add(' TMyB = class(TExtA)');
- Add(' protected');
- Add(' class function NewInstance(fnname: string; const paramarray): TMyB; virtual;');
- Add(' end;');
- Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
- Add('begin end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestExternalClass_NewInstance',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TMyB", ExtA, "NewInstance", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.NewInstance = function (fnname, paramarray) {',
- ' var Result = null;',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestExternalClass_NewInstance_NonVirtualFail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' end;');
- Add(' TMyB = class(TExtA)');
- Add(' protected');
- Add(' class function NewInstance(fnname: string; const paramarray): TMyB;');
- Add(' end;');
- Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
- Add('begin end;');
- Add('begin');
- SetExpectedPasResolverError(sNewInstanceFunctionMustBeVirtual,nNewInstanceFunctionMustBeVirtual);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_NewInstance_FirstParamNotString_Fail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' end;');
- Add(' TMyB = class(TExtA)');
- Add(' protected');
- Add(' class function NewInstance(fnname: longint; const paramarray): TMyB; virtual;');
- Add(' end;');
- Add('class function TMyB.NewInstance(fnname: longint; const paramarray): TMyB;');
- Add('begin end;');
- Add('begin');
- SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Longint", expected "String"',
- nIncompatibleTypeArgNo);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_NewInstance_SecondParamTyped_Fail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' end;');
- Add(' TMyB = class(TExtA)');
- Add(' protected');
- Add(' class function NewInstance(fnname: string; const paramarray: string): TMyB; virtual;');
- Add(' end;');
- Add('class function TMyB.NewInstance(fnname: string; const paramarray: string): TMyB;');
- Add('begin end;');
- Add('begin');
- SetExpectedPasResolverError('Incompatible type arg no. 2: Got "type", expected "untyped"',
- nIncompatibleTypeArgNo);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_JSFunctionPasDescendant;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSFunction = class external name ''Function''',
- ' end;',
- ' TExtA = class external name ''ExtA''(TJSFunction)',
- ' constructor New(w: word);',
- ' end;',
- ' TBird = class (TExtA)',
- ' public',
- ' Size: word;',
- ' class var Legs: word;',
- ' constructor Create(a: word);',
- ' end;',
- ' TEagle = class (TBird)',
- ' public',
- ' constructor Create(b: word); reintroduce;',
- ' end;',
- 'constructor TBird.Create(a: word);',
- 'begin',
- ' inherited;', // silently ignored
- ' inherited New(a);', // this.$func(a)
- 'end;',
- 'constructor TEagle.Create(b: word);',
- 'begin',
- ' inherited Create(b);',
- 'end;',
- 'var',
- ' Bird: TBird;',
- ' Eagle: TEagle;',
- 'begin',
- ' Bird:=TBird.Create(3);',
- ' Eagle:=TEagle.Create(4);',
- ' Bird.Size:=Bird.Size+5;',
- ' Bird.Legs:=Bird.Legs+6;',
- ' Eagle.Size:=Eagle.Size+5;',
- ' Eagle.Legs:=Eagle.Legs+6;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_JSFunctionPasDescendant',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TBird", ExtA, "", function () {',
- ' this.Legs = 0;',
- ' this.$init = function () {',
- ' this.Size = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function (a) {',
- ' this.$ancestorfunc(a);',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClassExt(this, "TEagle", this.TBird, "", function () {',
- ' this.Create$1 = function (b) {',
- ' $mod.TBird.Create.call(this, b);',
- ' return this;',
- ' };',
- '});',
- 'this.Bird = null;',
- 'this.Eagle = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Bird = $mod.TBird.$create("Create", [3]);',
- '$mod.Eagle = $mod.TEagle.$create("Create$1", [4]);',
- '$mod.Bird.Size = $mod.Bird.Size + 5;',
- '$mod.TBird.Legs = $mod.Bird.Legs + 6;',
- '$mod.Eagle.Size = $mod.Eagle.Size + 5;',
- '$mod.TBird.Legs = $mod.Eagle.Legs + 6;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_PascalProperty;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSElement = class;');
- Add(' TJSNotifyEvent = procedure(Sender: TJSElement) of object;');
- Add(' TJSElement = class external name ''ExtA''');
- Add(' end;');
- Add(' TControl = class(TJSElement)');
- Add(' private');
- Add(' FOnClick: TJSNotifyEvent;');
- Add(' property OnClick: TJSNotifyEvent read FOnClick write FOnClick;');
- Add(' procedure Click(Sender: TJSElement);');
- Add(' end;');
- Add('procedure TControl.Click(Sender: TJSElement);');
- Add('begin');
- Add(' OnClick(Self);');
- Add('end;');
- Add('var');
- Add(' Ctrl: TControl;');
- Add('begin');
- Add(' Ctrl.OnClick:[email protected];');
- Add(' Ctrl.OnClick(Ctrl);');
- ConvertProgram;
- CheckSource('TestExternalClass_PascalProperty',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TControl", ExtA, "", function () {',
- ' this.$init = function () {',
- ' this.FOnClick = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FOnClick = undefined;',
- ' };',
- ' this.Click = function (Sender) {',
- ' this.FOnClick(this);',
- ' };',
- '});',
- 'this.Ctrl = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Ctrl.FOnClick = rtl.createCallback($mod.Ctrl, "Click");',
- '$mod.Ctrl.FOnClick($mod.Ctrl);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastToRootClass;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' IUnknown = interface end;',
- ' TObject = class',
- ' end;',
- ' TChild = class',
- ' end;',
- ' TExtRootA = class external name ''ExtRootA''',
- ' end;',
- ' TExtChildA = class external name ''ExtChildA''(TExtRootA)',
- ' end;',
- ' TExtRootB = class external name ''ExtRootB''',
- ' end;',
- ' TExtChildB = class external name ''ExtChildB''(TExtRootB)',
- ' end;',
- 'var',
- ' Obj: TObject;',
- ' Child: TChild;',
- ' RootA: TExtRootA;',
- ' ChildA: TExtChildA;',
- ' RootB: TExtRootB;',
- ' ChildB: TExtChildB;',
- ' i: IUnknown;',
- 'begin',
- ' obj:=tobject(roota);',
- ' obj:=tobject(childa);',
- ' child:=tchild(tobject(roota));',
- ' roota:=textroota(obj);',
- ' roota:=textroota(child);',
- ' roota:=textroota(rootb);',
- ' roota:=textroota(childb);',
- ' childa:=textchilda(textroota(obj));',
- ' roota:=TExtRootA(i)',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastToRootClass',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TChild", this.TObject, function () {',
- '});',
- 'this.Obj = null;',
- 'this.Child = null;',
- 'this.RootA = null;',
- 'this.ChildA = null;',
- 'this.RootB = null;',
- 'this.ChildB = null;',
- 'this.i = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.RootA;',
- '$mod.Obj = $mod.ChildA;',
- '$mod.Child = $mod.RootA;',
- '$mod.RootA = $mod.Obj;',
- '$mod.RootA = $mod.Child;',
- '$mod.RootA = $mod.RootB;',
- '$mod.RootA = $mod.ChildB;',
- '$mod.ChildA = $mod.Obj;',
- '$mod.RootA = $mod.i;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastToJSObject;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' IUnknown = interface end;',
- ' IBird = interface(IUnknown) end;',
- ' TClass = class of TObject;',
- ' TObject = class',
- ' end;',
- ' TChild = class',
- ' end;',
- ' TJSObject = class external name ''Object''',
- ' end;',
- ' TRec = record end;',
- 'var',
- ' Obj: TObject;',
- ' Child: TChild;',
- ' i: IUnknown;',
- ' Bird: IBird;',
- ' j: TJSObject;',
- ' r: TRec;',
- ' c: TClass;',
- 'begin',
- ' j:=tjsobject(IUnknown);',
- ' j:=tjsobject(IBird);',
- ' j:=tjsobject(TObject);',
- ' j:=tjsobject(TChild);',
- ' j:=tjsobject(TRec);',
- ' j:=tjsobject(Obj);',
- ' j:=tjsobject(Child);',
- ' j:=tjsobject(i);',
- ' j:=tjsobject(Bird);',
- ' j:=tjsobject(r);',
- ' j:=tjsobject(c);',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastToJSObject',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], this.IUnknown);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TChild", this.TObject, function () {',
- '});',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.Child = null;',
- 'this.i = null;',
- 'this.Bird = null;',
- 'this.j = null;',
- 'this.r = this.TRec.$new();',
- 'this.c = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.j = $mod.IUnknown;',
- '$mod.j = $mod.IBird;',
- '$mod.j = $mod.TObject;',
- '$mod.j = $mod.TChild;',
- '$mod.j = $mod.TRec;',
- '$mod.j = $mod.Obj;',
- '$mod.j = $mod.Child;',
- '$mod.j = $mod.i;',
- '$mod.j = $mod.Bird;',
- '$mod.j = $mod.r;',
- '$mod.j = $mod.c;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastStringToExternalString;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSString = class external name ''String''');
- Add(' class function fromCharCode() : string; varargs;');
- Add(' function anchor(const aName : string) : string;');
- Add(' end;');
- Add('var');
- Add(' s: string;');
- Add('begin');
- Add(' s:=TJSString.fromCharCode(65,66);');
- Add(' s:=TJSString(s).anchor(s);');
- Add(' s:=TJSString(''foo'').anchor(s);');
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastStringToExternalString',
- LinesToStr([ // statements
- 'this.s = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.s = String.fromCharCode(65, 66);',
- '$mod.s = $mod.s.anchor($mod.s);',
- '$mod.s = "foo".anchor($mod.s);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastToJSFunction;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSObject = class external name ''Object'' end;',
- ' TJSFunction = class external name ''Function''',
- ' function bind(thisArg: TJSObject): TJSFunction; varargs;',
- ' function call(thisArg: TJSObject): JSValue; varargs;',
- ' end;',
- ' TObject = class',
- ' procedure DoIt(i: longint);',
- ' end;',
- ' TFuncInt = function(o: TObject): longint;',
- 'function GetIt(o: TObject): longint;',
- ' procedure Sub; begin end;',
- 'var',
- ' f: TJSFunction;',
- ' fi: TFuncInt;',
- 'begin',
- ' fi:=TFuncInt(f);',
- ' f:=TJSFunction(fi);',
- ' f:=TJSFunction(@GetIt);',
- ' f:=TJSFunction(@GetIt).bind(nil,3);',
- ' f:=TJSFunction(@Sub);',
- ' f:=TJSFunction(@o.doit);',
- ' f:=TJSFunction(fi).bind(nil,4)',
- 'end;',
- 'procedure TObject.DoIt(i: longint);',
- ' procedure Sub; begin end;',
- 'var f: TJSFunction;',
- 'begin',
- ' f:=TJSFunction(@DoIt);',
- ' f:=TJSFunction(@DoIt).bind(nil,13);',
- ' f:=TJSFunction(@Sub);',
- ' f:=TJSFunction(@GetIt);',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastToJSFunction',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (i) {',
- ' var $Self = this;',
- ' function Sub() {',
- ' };',
- ' var f = null;',
- ' f = this.DoIt;',
- ' f = this.DoIt.bind(null, 13);',
- ' f = Sub;',
- ' f = $mod.GetIt;',
- ' };',
- '});',
- 'this.GetIt = function (o) {',
- ' var Result = 0;',
- ' function Sub() {',
- ' };',
- ' var f = null;',
- ' var fi = null;',
- ' fi = f;',
- ' f = fi;',
- ' f = $mod.GetIt;',
- ' f = $mod.GetIt.bind(null, 3);',
- ' f = Sub;',
- ' f = $mod.TObject.DoIt;',
- ' f = fi.bind(null, 4);',
- ' return Result;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastDelphiUnrelated;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSObject = class external name ''Object'' end;',
- ' TJSWindow = class external name ''Window''(TJSObject)',
- ' procedure Open;',
- ' end;',
- ' TJSEventTarget = class external name ''Event''(TJSObject)',
- ' procedure Execute;',
- ' end;',
- 'procedure Fly;',
- 'var',
- ' w: TJSWindow;',
- ' e: TJSEventTarget;',
- 'begin',
- ' w:=TJSWindow(e);',
- ' e:=TJSEventTarget(w);',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastDelphiUnrelated',
- LinesToStr([ // statements
- 'this.Fly = function () {',
- ' var w = null;',
- ' var e = null;',
- ' w = e;',
- ' e = w;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSString = class external name ''String''');
- Add(' class function fromCharCode() : string; varargs;');
- Add(' end;');
- Add('var');
- Add(' s: string;');
- Add(' sObj: TJSString;');
- Add('begin');
- Add(' s:=sObj.fromCharCode(65,66);');
- SetExpectedPasResolverError('External class instance cannot access static class function fromCharCode',
- nExternalClassInstanceCannotAccessStaticX);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_BracketAccessor;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSArray = class external name ''Array2''',
- ' function GetItems(Index: longint): jsvalue; external name ''[]'';',
- ' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';',
- ' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;',
- ' end;',
- 'procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);',
- 'begin end;',
- 'var',
- ' Arr: tjsarray;',
- ' s: string;',
- ' i: longint;',
- ' v: jsvalue;',
- 'begin',
- ' v:=arr[0];',
- ' v:=arr.items[1];',
- ' arr[2]:=s;',
- ' arr.items[3]:=s;',
- ' arr[4]:=i;',
- ' arr[5]:=arr[6];',
- ' arr.items[7]:=arr.items[8];',
- ' with arr do items[9]:=items[10];',
- ' doit(arr[7],arr[8],arr[9],arr[10]);',
- ' with arr do begin',
- ' v:=GetItems(14);',
- ' setitems(15,16);',
- ' end;',
- ' v:=test1.arr.items[17];',
- ' test1.arr.items[18]:=v;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_BracketAccessor',
- LinesToStr([ // statements
- 'this.DoIt = function (vI, vJ, vK, vL) {',
- '};',
- 'this.Arr = null;',
- 'this.s = "";',
- 'this.i = 0;',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.Arr[0];',
- '$mod.v = $mod.Arr[1];',
- '$mod.Arr[2] = $mod.s;',
- '$mod.Arr[3] = $mod.s;',
- '$mod.Arr[4] = $mod.i;',
- '$mod.Arr[5] = $mod.Arr[6];',
- '$mod.Arr[7] = $mod.Arr[8];',
- 'var $with = $mod.Arr;',
- '$with[9] = $with[10];',
- '$mod.DoIt($mod.Arr[7], $mod.Arr[8], {',
- ' a: 9,',
- ' p: $mod.Arr,',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- '}, {',
- ' a: 10,',
- ' p: $mod.Arr,',
- ' get: function () {',
- ' return this.p[this.a];',
- ' },',
- ' set: function (v) {',
- ' this.p[this.a] = v;',
- ' }',
- '});',
- 'var $with1 = $mod.Arr;',
- '$mod.v = $with1[14];',
- '$with1[15] = 16;',
- '$mod.v = $mod.Arr[17];',
- '$mod.Arr[18] = $mod.v;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_BracketAccessor_Call;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSArray = class external name ''Array2''',
- ' function GetItems(Index: longint): jsvalue; external name ''[]'';',
- ' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';',
- ' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;',
- ' end;',
- ' TMyArr = class(TJSArray)',
- ' procedure DoIt;',
- ' end;',
- 'procedure tmyarr.DoIt;',
- 'begin',
- ' Items[1]:=Items[2];',
- ' SetItems(3,getItems(4));',
- 'end;',
- 'var',
- ' Arr: tmyarr;',
- ' s: string;',
- ' i: longint;',
- ' v: jsvalue;',
- 'begin',
- ' v:=arr[0];',
- ' v:=arr.items[1];',
- ' arr[2]:=s;',
- ' arr.items[3]:=s;',
- ' arr[4]:=i;',
- ' arr[5]:=arr[6];',
- ' arr.items[7]:=arr.items[8];',
- ' with arr do items[9]:=items[10];',
- ' with arr do begin',
- ' v:=GetItems(14);',
- ' setitems(15,16);',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_BracketAccessor_Call',
- LinesToStr([ // statements
- 'rtl.createClassExt(this, "TMyArr", Array2, "", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' this[1] = this[2];',
- ' this[3] = this[4];',
- ' };',
- '});',
- 'this.Arr = null;',
- 'this.s = "";',
- 'this.i = 0;',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.Arr[0];',
- '$mod.v = $mod.Arr[1];',
- '$mod.Arr[2] = $mod.s;',
- '$mod.Arr[3] = $mod.s;',
- '$mod.Arr[4] = $mod.i;',
- '$mod.Arr[5] = $mod.Arr[6];',
- '$mod.Arr[7] = $mod.Arr[8];',
- 'var $with = $mod.Arr;',
- '$with[9] = $with[10];',
- 'var $with1 = $mod.Arr;',
- '$mod.v = $with1[14];',
- '$with1[15] = 16;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_BracketAccessor_2ParamsFail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSArray = class external name ''Array2''');
- Add(' function GetItems(Index1, Index2: longint): jsvalue; external name ''[]'';');
- Add(' procedure SetItems(Index1, Index2: longint; Value: jsvalue); external name ''[]'';');
- Add(' property Items[Index1, Index2: longint]: jsvalue read GetItems write SetItems; default;');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError(sBracketAccessorOfExternalClassMustHaveOneParameter,
- nBracketAccessorOfExternalClassMustHaveOneParameter);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_BracketAccessor_ReadOnly;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSArray = class external name ''Array2''');
- Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
- Add(' property Items[Index: longint]: jsvalue read GetItems; default;');
- Add(' end;');
- Add('procedure DoIt(vI: JSValue; const vJ: jsvalue);');
- Add('begin end;');
- Add('var');
- Add(' Arr: tjsarray;');
- Add(' v: jsvalue;');
- Add('begin');
- Add(' v:=arr[0];');
- Add(' v:=arr.items[1];');
- Add(' with arr do v:=items[2];');
- Add(' doit(arr[3],arr[4]);');
- ConvertProgram;
- CheckSource('TestExternalClass_BracketAccessor_ReadOnly',
- LinesToStr([ // statements
- 'this.DoIt = function (vI, vJ) {',
- '};',
- 'this.Arr = null;',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.Arr[0];',
- '$mod.v = $mod.Arr[1];',
- 'var $with = $mod.Arr;',
- '$mod.v = $with[2];',
- '$mod.DoIt($mod.Arr[3], $mod.Arr[4]);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_BracketAccessor_WriteOnly;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSArray = class external name ''Array2''');
- Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
- Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
- Add(' end;');
- Add('var');
- Add(' Arr: tjsarray;');
- Add(' s: string;');
- Add(' i: longint;');
- Add(' v: jsvalue;');
- Add('begin');
- Add(' arr[2]:=s;');
- Add(' arr.items[3]:=s;');
- Add(' arr[4]:=i;');
- Add(' with arr do items[5]:=i;');
- ConvertProgram;
- CheckSource('TestExternalClass_BracketAccessor_WriteOnly',
- LinesToStr([ // statements
- 'this.Arr = null;',
- 'this.s = "";',
- 'this.i = 0;',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Arr[2] = $mod.s;',
- '$mod.Arr[3] = $mod.s;',
- '$mod.Arr[4] = $mod.i;',
- 'var $with = $mod.Arr;',
- '$with[5] = $mod.i;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_BracketAccessor_MultiType;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSArray = class external name ''Array2''');
- Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
- Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
- Add(' procedure SetNumbers(Index: longint; Value: longint); external name ''[]'';');
- Add(' property Numbers[Index: longint]: longint write SetNumbers;');
- Add(' end;');
- Add('var');
- Add(' Arr: tjsarray;');
- Add(' s: string;');
- Add(' i: longint;');
- Add(' v: jsvalue;');
- Add('begin');
- Add(' arr[2]:=s;');
- Add(' arr.items[3]:=s;');
- Add(' arr.numbers[4]:=i;');
- Add(' with arr do items[5]:=i;');
- Add(' with arr do numbers[6]:=i;');
- ConvertProgram;
- CheckSource('TestExternalClass_BracketAccessor_MultiType',
- LinesToStr([ // statements
- 'this.Arr = null;',
- 'this.s = "";',
- 'this.i = 0;',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Arr[2] = $mod.s;',
- '$mod.Arr[3] = $mod.s;',
- '$mod.Arr[4] = $mod.i;',
- 'var $with = $mod.Arr;',
- '$with[5] = $mod.i;',
- 'var $with1 = $mod.Arr;',
- '$with1[6] = $mod.i;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_BracketAccessor_Index;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSArray = class external name ''Array2''');
- Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
- Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
- Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
- Add(' end;');
- Add('var');
- Add(' Arr: tjsarray;');
- Add(' i: longint;');
- Add(' IntArr: array of longint;');
- Add(' v: jsvalue;');
- Add('begin');
- Add(' v:=arr.items[i];');
- Add(' arr[longint(v)]:=arr.items[intarr[0]];');
- Add(' arr.items[intarr[1]]:=arr[IntArr[2]];');
- ConvertProgram;
- CheckSource('TestExternalClass_BracketAccessor_Index',
- LinesToStr([ // statements
- 'this.Arr = null;',
- 'this.i = 0;',
- 'this.IntArr = [];',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.Arr[$mod.i];',
- '$mod.Arr[rtl.trunc($mod.v)] = $mod.Arr[$mod.IntArr[0]];',
- '$mod.Arr[$mod.IntArr[1]] = $mod.Arr[$mod.IntArr[2]];',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ForInJSObject;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSObject = class external name ''Object''',
- ' end;',
- 'var',
- ' o: TJSObject;',
- ' key: string;',
- 'begin',
- ' for key in o do',
- ' if key=''abc'' then ;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_ForInJSObject',
- LinesToStr([ // statements
- 'this.o = null;',
- 'this.key = "";',
- '']),
- LinesToStr([ // $mod.$main
- 'for ($mod.key in $mod.o) if ($mod.key === "abc") ;',
- '']));
- end;
- procedure TTestModule.TestExternalClass_ForInJSArray;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSInt8Array = class external name ''Int8Array''',
- ' private',
- ' flength: NativeInt external name ''length'';',
- ' function getValue(Index: NativeInt): shortint; external name ''[]'';',
- ' public',
- ' property values[Index: NativeInt]: Shortint Read getValue; default;',
- ' property Length: NativeInt read flength;',
- ' end;',
- 'var',
- ' a: TJSInt8Array;',
- ' value: shortint;',
- 'begin',
- ' for value in a do',
- ' if value=3 then ;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_ForInJSArray',
- LinesToStr([ // statements
- 'this.a = null;',
- 'this.value = 0;',
- '']),
- LinesToStr([ // $mod.$main
- 'for (var $in = $mod.a, $l = 0, $end = rtl.length($in) - 1; $l <= $end; $l++) {',
- ' $mod.value = $in[$l];',
- ' if ($mod.value === 3) ;',
- '};',
- '']));
- end;
- procedure TTestModule.TestExternalClass_IncompatibleArgDuplicateIdentifier;
- begin
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSBufferSource = class external name ''BufferSource''',
- ' end;',
- 'procedure DoIt(s: TJSBufferSource); external name ''DoIt'';',
- '']),
- '');
- AddModuleWithIntfImplSrc('unit3.pas',
- LinesToStr([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSBufferSource = class external name ''BufferSource''',
- ' end;',
- '']),
- '');
- StartUnit(true);
- Add([
- 'interface',
- 'uses unit2, unit3;',
- 'procedure DoSome(s: TJSBufferSource);',
- 'implementation',
- 'procedure DoSome(s: TJSBufferSource);',
- 'begin',
- ' DoIt(s);',
- 'end;',
- '']);
- SetExpectedPasResolverError('Incompatible type arg no. 1: Got "unit3.TJSBufferSource", expected "unit2.TJSBufferSource"',
- nIncompatibleTypeArgNo);
- ConvertUnit;
- end;
- procedure TTestModule.TestClassInterface_Corba;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface;',
- ' IUnknown = interface',
- ' [''{00000000-0000-0000-C000-000000000046}'']',
- ' end;',
- ' IInterface = IUnknown;',
- ' IBird = interface(IInterface)',
- ' function GetSize: longint;',
- ' procedure SetSize(i: longint);',
- ' property Size: longint read GetSize write SetSize;',
- ' procedure DoIt(i: longint);',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TBird = class(TObject,IBird)',
- ' function GetSize: longint; virtual; abstract;',
- ' procedure SetSize(i: longint); virtual; abstract;',
- ' procedure DoIt(i: longint); virtual; abstract;',
- ' end;',
- 'var',
- ' BirdIntf: IBird;',
- 'begin',
- ' BirdIntf.Size:=BirdIntf.Size;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Corba',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{00000000-0000-0000-C000-000000000046}", [], null);',
- 'rtl.createInterface(this, "IBird", "{5BD1A53B-69BB-37EE-AF32-BEFB86D85B03}", ["GetSize", "SetSize", "DoIt"], this.IUnknown);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.addIntf(this, $mod.IBird);',
- '});',
- 'this.BirdIntf = null;',
- '']),
- LinesToStr([ // $mod.$main
- ' $mod.BirdIntf.SetSize($mod.BirdIntf.GetSize());',
- '']));
- end;
- procedure TTestModule.TestClassInterface_ProcExternalFail;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' procedure DoIt; external name ''foo'';',
- ' end;',
- 'begin']);
- SetExpectedParserError(
- 'Fields are not allowed in interface at token "Identifier external" in file test1.pp at line 6 column 21',
- nParserNoFieldsAllowed);
- ConvertProgram;
- end;
- procedure TTestModule.TestClassInterface_Overloads;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' integer = longint;',
- ' IUnknown = interface',
- ' procedure DoIt(i: integer);',
- ' procedure DoIt(s: string);',
- ' end;',
- ' IBird = interface(IUnknown)',
- ' procedure DoIt(b: boolean); overload;',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TBird = class(TObject,IBird)',
- ' procedure DoIt(o: TObject);',
- ' procedure DoIt(s: string);',
- ' procedure DoIt(i: integer);',
- ' procedure DoIt(b: boolean);',
- ' end;',
- 'procedure TBird.DoIt(o: TObject); begin end;',
- 'procedure TBird.DoIt(s: string); begin end;',
- 'procedure TBird.DoIt(i: integer); begin end;',
- 'procedure TBird.DoIt(b: boolean); begin end;',
- 'var',
- ' BirdIntf: IBird;',
- 'begin',
- ' BirdIntf.DoIt(3);',
- ' BirdIntf.DoIt(''abc'');',
- ' BirdIntf.DoIt(true);',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Overloads',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2AE2C59400}", ["DoIt", "DoIt$1"], null);',
- 'rtl.createInterface(this, "IBird", "{8285DD5E-EA3E-396E-AE88-000B86AABF05}", ["DoIt$2"], this.IUnknown);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function (o) {',
- ' };',
- ' this.DoIt$1 = function (s) {',
- ' };',
- ' this.DoIt$2 = function (i) {',
- ' };',
- ' this.DoIt$3 = function (b) {',
- ' };',
- ' rtl.addIntf(this, $mod.IBird, {',
- ' DoIt$2: "DoIt$3",',
- ' DoIt: "DoIt$2"',
- ' });',
- '});',
- 'this.BirdIntf = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.BirdIntf.DoIt(3);',
- '$mod.BirdIntf.DoIt$1("abc");',
- '$mod.BirdIntf.DoIt$2(true);',
- '']));
- end;
- procedure TTestModule.TestClassInterface_DuplicateGUIInIntfListFail;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IBird = interface',
- ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
- ' end;',
- ' IDog = interface',
- ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
- ' end;',
- ' TObject = class(IBird,IDog)',
- ' end;',
- 'begin']);
- SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IDog and IBird',
- nDuplicateGUIDXInYZ);
- ConvertProgram;
- end;
- procedure TTestModule.TestClassInterface_DuplicateGUIInAncestorFail;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IAnimal = interface',
- ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
- ' end;',
- ' IBird = interface(IAnimal)',
- ' end;',
- ' IHawk = interface(IBird)',
- ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
- ' end;',
- 'begin']);
- SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IHawk and IAnimal',
- nDuplicateGUIDXInYZ);
- ConvertProgram;
- end;
- procedure TTestModule.TestClassInterface_AncestorImpl;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' integer = longint;',
- ' IUnknown = interface',
- ' procedure DoIt(i: integer);',
- ' end;',
- ' IBird = interface',
- ' procedure Fly(i: integer);',
- ' end;',
- ' TObject = class(IUnknown)',
- ' procedure DoIt(i: integer);',
- ' end;',
- ' TBird = class(IBird)',
- ' procedure Fly(i: integer);',
- ' end;',
- 'procedure TObject.DoIt(i: integer); begin end;',
- 'procedure TBird.Fly(i: integer); begin end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_AncestorIntf',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2800000000}", ["DoIt"], null);',
- 'rtl.createInterface(this, "IBird", "{B92D5841-6264-3AE3-BF20-000000000000}", ["Fly"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (i) {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Fly = function (i) {',
- ' };',
- ' rtl.addIntf(this, $mod.IBird);',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_ImplReintroduce;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' integer = longint;',
- ' IBird = interface',
- ' procedure DoIt(i: integer);',
- ' end;',
- ' TObject = class',
- ' procedure DoIt(i: integer);',
- ' end;',
- ' TBird = class(IBird)',
- ' procedure DoIt(i: integer); virtual; reintroduce;',
- ' end;',
- 'procedure TObject.DoIt(i: integer); begin end;',
- 'procedure TBird.DoIt(i: integer); begin end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_ImplReintroduce',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IBird", "{B92D5841-6264-3AE2-8594-000000000000}", ["DoIt"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (i) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt$1 = function (i) {',
- ' };',
- ' rtl.addIntf(this, $mod.IBird, {',
- ' DoIt: "DoIt$1"',
- ' });',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_MethodResolution;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' procedure Walk(i: longint);',
- ' end;',
- ' IBird = interface(IUnknown)',
- ' procedure Walk(b: boolean); overload;',
- ' procedure Fly(s: string);',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TBird = class(TObject,IBird)',
- ' procedure IBird.Fly = Move;',
- ' procedure IBird.Walk = Hop;',
- ' procedure Hop(i: longint);',
- ' procedure Move(s: string);',
- ' procedure Hop(b: boolean);',
- ' end;',
- 'procedure TBird.Move(s: string); begin end;',
- 'procedure TBird.Hop(i: longint); begin end;',
- 'procedure TBird.Hop(b: boolean); begin end;',
- 'var',
- ' BirdIntf: IBird;',
- 'begin',
- ' BirdIntf.Walk(3);',
- ' BirdIntf.Walk(true);',
- ' BirdIntf.Fly(''abc'');',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_MethodResolution',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-BDD7-23D600000000}", ["Walk"], null);',
- 'rtl.createInterface(this, "IBird", "{CF8A4986-80F6-396E-AE88-000B86AAE208}", ["Walk$1", "Fly"], this.IUnknown);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Hop = function (i) {',
- ' };',
- ' this.Move = function (s) {',
- ' };',
- ' this.Hop$1 = function (b) {',
- ' };',
- ' rtl.addIntf(this, $mod.IBird, {',
- ' Walk$1: "Hop$1",',
- ' Fly: "Move",',
- ' Walk: "Hop"',
- ' });',
- '});',
- 'this.BirdIntf = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.BirdIntf.Walk(3);',
- '$mod.BirdIntf.Walk$1(true);',
- '$mod.BirdIntf.Fly("abc");',
- '']));
- end;
- procedure TTestModule.TestClassInterface_AncestorMoreInterfaces;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' procedure Walk;',
- ' end;',
- ' IBird = interface end;',
- ' IDog = interface end;',
- ' TObject = class(IBird,IDog)',
- ' function _AddRef: longint; virtual; abstract;',
- ' procedure Walk; virtual; abstract;',
- ' end;',
- ' TBird = class(IUnknown)',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_AncestorLess',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{8F2D5841-758A-322B-BDDF-21CD521DD723}", ["_AddRef", "Walk"], null);',
- 'rtl.createInterface(this, "IBird", "{CCE11D4C-6504-3AEE-AE88-000B86AAE675}", [], this.IUnknown);',
- 'rtl.createInterface(this, "IDog", "{CCE11D4C-6504-3AEE-AE88-000B8E5FC675}", [], this.IUnknown);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IBird);',
- ' rtl.addIntf(this, $mod.IDog);',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.addIntf(this, $mod.IUnknown);',
- ' rtl.addIntf(this, $mod.IBird);',
- ' rtl.addIntf(this, $mod.IDog);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_MethodOverride;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' [''{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}'']',
- ' procedure Go;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' procedure Go; virtual; abstract;',
- ' end;',
- ' TBird = class',
- ' procedure Go; override;',
- ' end;',
- ' TCat = class(TObject)',
- ' procedure Go; override;',
- ' end;',
- ' TDog = class(TObject, IUnknown)',
- ' procedure Go; override;',
- ' end;',
- 'procedure TBird.Go; begin end;',
- 'procedure TCat.Go; begin end;',
- 'procedure TDog.Go; begin end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_MethodOverride',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}", ["Go"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Go = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'rtl.createClass(this, "TCat", this.TObject, function () {',
- ' this.Go = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'rtl.createClass(this, "TDog", this.TObject, function () {',
- ' this.Go = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_Corba_Delegation;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' end;',
- ' IBird = interface(IUnknown)',
- ' procedure Fly(s: string);',
- ' end;',
- ' IEagle = interface(IBird)',
- ' end;',
- ' IDove = interface(IBird)',
- ' end;',
- ' ISwallow = interface(IBird)',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
- ' procedure Fly(s: string); virtual; abstract;',
- ' end;',
- ' TBat = class(IBird,IEagle,IDove,ISwallow)',
- ' FBirdIntf: IBird;',
- ' property BirdIntf: IBird read FBirdIntf implements IBird;',
- ' function GetEagleIntf: IEagle; virtual; abstract;',
- ' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
- ' FDoveObj: TBird;',
- ' property DoveObj: TBird read FDoveObj implements IDove;',
- ' function GetSwallowObj: TBird; virtual; abstract;',
- ' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Corba_Delegation',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], this.IUnknown);',
- 'rtl.createInterface(this, "IEagle", "{489289DE-FDE2-34A6-8288-39119022B1B4}", [], this.IBird);',
- 'rtl.createInterface(this, "IDove", "{489289DE-FDE2-34A6-8288-39118EF16074}", [], this.IBird);',
- 'rtl.createInterface(this, "ISwallow", "{B89289DE-FDE2-34A6-8288-3911CBDCB359}", [], this.IBird);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.addIntf(this, $mod.IBird);',
- ' rtl.addIntf(this, $mod.IEagle);',
- ' rtl.addIntf(this, $mod.IDove);',
- ' rtl.addIntf(this, $mod.ISwallow);',
- '});',
- 'rtl.createClass(this, "TBat", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FBirdIntf = null;',
- ' this.FDoveObj = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FBirdIntf = undefined;',
- ' this.FDoveObj = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- ' this.$intfmaps = {',
- ' "{478D080B-C0F6-396E-AE88-000B87785B07}": function () {',
- ' return this.FBirdIntf;',
- ' },',
- ' "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
- ' return this.GetEagleIntf();',
- ' },',
- ' "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
- ' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
- ' },',
- ' "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
- ' return rtl.getIntfT(this.GetSwallowObj(), $mod.ISwallow);',
- ' }',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_Corba_DelegationStatic;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' end;',
- ' IBird = interface(IUnknown)',
- ' procedure Fly(s: string);',
- ' end;',
- ' IEagle = interface(IBird)',
- ' end;',
- ' IDove = interface(IBird)',
- ' end;',
- ' ISwallow = interface(IBird)',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
- ' procedure Fly(s: string); virtual; abstract;',
- ' end;',
- ' TBat = class(IBird,IEagle,IDove,ISwallow)',
- ' private',
- ' class var FBirdIntf: IBird;',
- ' class var FDoveObj: TBird;',
- ' class function GetEagleIntf: IEagle; virtual; abstract;',
- ' class function GetSwallowObj: TBird; virtual; abstract;',
- ' protected',
- ' class property BirdIntf: IBird read FBirdIntf implements IBird;',
- ' class property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
- ' class property DoveObj: TBird read FDoveObj implements IDove;',
- ' class property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Corba_DelegationStatic',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], this.IUnknown);',
- 'rtl.createInterface(this, "IEagle", "{489289DE-FDE2-34A6-8288-39119022B1B4}", [], this.IBird);',
- 'rtl.createInterface(this, "IDove", "{489289DE-FDE2-34A6-8288-39118EF16074}", [], this.IBird);',
- 'rtl.createInterface(this, "ISwallow", "{B89289DE-FDE2-34A6-8288-3911CBDCB359}", [], this.IBird);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.addIntf(this, $mod.IBird);',
- ' rtl.addIntf(this, $mod.IEagle);',
- ' rtl.addIntf(this, $mod.IDove);',
- ' rtl.addIntf(this, $mod.ISwallow);',
- '});',
- 'rtl.createClass(this, "TBat", this.TObject, function () {',
- ' this.FBirdIntf = null;',
- ' this.FDoveObj = null;',
- ' this.$intfmaps = {',
- ' "{478D080B-C0F6-396E-AE88-000B87785B07}": function () {',
- ' return this.FBirdIntf;',
- ' },',
- ' "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
- ' return this.GetEagleIntf();',
- ' },',
- ' "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
- ' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
- ' },',
- ' "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
- ' return rtl.getIntfT(this.GetSwallowObj(), $mod.ISwallow);',
- ' }',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_Corba_Operators;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' end;',
- ' IBird = interface(IUnknown)',
- ' function GetItems(Index: longint): longint;',
- ' procedure SetItems(Index: longint; Value: longint);',
- ' property Items[Index: longint]: longint read GetItems write SetItems; default;',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TBird = class(TObject,IBird)',
- ' function GetItems(Index: longint): longint; virtual; abstract;',
- ' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
- ' end;',
- 'var',
- ' IntfVar: IBird = nil;',
- ' IntfVar2: IBird;',
- ' ObjVar: TBird;',
- ' v: JSValue;',
- 'begin',
- ' IntfVar:=nil;',
- ' IntfVar[3]:=IntfVar[4];',
- ' if Assigned(IntfVar) then ;',
- ' IntfVar:=IntfVar2;',
- ' IntfVar:=ObjVar;',
- ' if IntfVar=IntfVar2 then ;',
- ' if IntfVar<>IntfVar2 then ;',
- ' if IntfVar is IBird then ;',
- ' if IntfVar is TBird then ;',
- ' if ObjVar is IBird then ;',
- ' IntfVar:=IntfVar2 as IBird;',
- ' ObjVar:=IntfVar2 as TBird;',
- ' IntfVar:=ObjVar as IBird;',
- ' IntfVar:=IBird(IntfVar2);',
- ' ObjVar:=TBird(IntfVar);',
- ' IntfVar:=IBird(ObjVar);',
- ' v:=IntfVar;',
- ' IntfVar:=IBird(v);',
- ' if v is IBird then ;',
- ' v:=JSValue(IntfVar);',
- ' v:=IBird;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Corba_Operators',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{D53FED90-DE59-3202-B1AE-000B87785B08}", ["GetItems", "SetItems"], this.IUnknown);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.addIntf(this, $mod.IBird);',
- '});',
- 'this.IntfVar = null;',
- 'this.IntfVar2 = null;',
- 'this.ObjVar = null;',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.IntfVar = null;',
- '$mod.IntfVar.SetItems(3, $mod.IntfVar.GetItems(4));',
- 'if ($mod.IntfVar != null) ;',
- '$mod.IntfVar = $mod.IntfVar2;',
- '$mod.IntfVar = rtl.getIntfT($mod.ObjVar,$mod.IBird);',
- 'if ($mod.IntfVar === $mod.IntfVar2) ;',
- 'if ($mod.IntfVar !== $mod.IntfVar2) ;',
- 'if ($mod.IBird.isPrototypeOf($mod.IntfVar)) ;',
- 'if (rtl.intfIsClass($mod.IntfVar, $mod.TBird)) ;',
- 'if (rtl.getIntfT($mod.ObjVar, $mod.IBird) !== null) ;',
- '$mod.IntfVar = rtl.as($mod.IntfVar2, $mod.IBird);',
- '$mod.ObjVar = rtl.intfAsClass($mod.IntfVar2, $mod.TBird);',
- '$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
- '$mod.IntfVar = $mod.IntfVar2;',
- '$mod.ObjVar = rtl.intfToClass($mod.IntfVar, $mod.TBird);',
- '$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
- '$mod.v = $mod.IntfVar;',
- '$mod.IntfVar = rtl.getObject($mod.v);',
- 'if (rtl.isExt($mod.v, $mod.IBird, 1)) ;',
- '$mod.v = $mod.IntfVar;',
- '$mod.v = $mod.IBird;',
- '']));
- end;
- procedure TTestModule.TestClassInterface_Corba_Args;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' end;',
- ' IBird = interface(IUnknown)',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TBird = class(TObject,IBird)',
- ' end;',
- 'procedure DoIt(var u; i: IBird; const j: IBird);',
- 'begin',
- ' DoIt(i,i,i);',
- 'end;',
- 'procedure Change(var i: IBird; out j: IBird);',
- 'begin',
- ' DoIt(i,i,i);',
- ' Change(i,i);',
- 'end;',
- 'var',
- ' i: IBird;',
- ' o: TBird;',
- 'begin',
- ' DoIt(i,i,i);',
- ' Change(i,i);',
- ' DoIt(o,o,o);',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Corba_Args',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], this.IUnknown);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.addIntf(this, $mod.IBird);',
- '});',
- 'this.DoIt = function (u, i, j) {',
- ' $mod.DoIt({',
- ' get: function () {',
- ' return i;',
- ' },',
- ' set: function (v) {',
- ' i = v;',
- ' }',
- ' }, i, i);',
- '};',
- 'this.Change = function (i, j) {',
- ' $mod.DoIt(i, i.get(), i.get());',
- ' $mod.Change(i, i);',
- '};',
- 'this.i = null;',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '}, $mod.i, $mod.i);',
- '$mod.Change({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '}, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});',
- '$mod.DoIt({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.o;',
- ' },',
- ' set: function (v) {',
- ' this.p.o = v;',
- ' }',
- '}, rtl.getIntfT($mod.o, $mod.IBird), rtl.getIntfT($mod.o, $mod.IBird));',
- '']));
- end;
- procedure TTestModule.TestClassInterface_Corba_ForIn;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface end;',
- ' TObject = class',
- ' Id: longint;',
- ' end;',
- ' IEnumerator = interface(IUnknown)',
- ' function GetCurrent: TObject;',
- ' function MoveNext: Boolean;',
- ' property Current: TObject read GetCurrent;',
- ' end;',
- ' IEnumerable = interface(IUnknown)',
- ' function GetEnumerator: IEnumerator;',
- ' end;',
- 'var',
- ' o: TObject;',
- ' i: IEnumerable;',
- 'begin',
- ' for o in i do o.Id:=3;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Corba_ForIn',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Id = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createInterface(this, "IEnumerator", "{95D7745D-ED61-3F13-BBE4-07708161999E}", ["GetCurrent", "MoveNext"], this.IUnknown);',
- 'rtl.createInterface(this, "IEnumerable", "{8CC9D45D-ED7D-3B73-96B6-290B931BB19E}", ["GetEnumerator"], this.IUnknown);',
- 'this.o = null;',
- 'this.i = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'var $in = $mod.i.GetEnumerator();',
- 'while ($in.MoveNext()) {',
- ' $mod.o = $in.GetCurrent();',
- ' $mod.o.Id = 3;',
- '};',
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_AssignVar;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' end;',
- 'var',
- ' i: IUnknown;',
- 'procedure DoGlobal(o: TObject);',
- 'begin',
- ' i:=nil;',
- ' i:=o;',
- ' i:=i;',
- 'end;',
- 'procedure DoLocal(o: TObject);',
- 'const k: IUnknown = nil;',
- 'var j: IUnknown;',
- 'begin',
- ' k:=o;',
- ' k:=i;',
- ' j:=o;',
- ' j:=i;',
- 'end;',
- 'var o: TObject;',
- 'begin',
- ' i:=nil;',
- ' i:=o;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_AssignVar',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.i = null;',
- 'this.DoGlobal = function (o) {',
- ' rtl.setIntfP($mod, "i", null);',
- ' rtl.setIntfP($mod, "i", rtl.queryIntfT(o, $mod.IUnknown), true);',
- ' rtl.setIntfP($mod, "i", $mod.i);',
- '};',
- 'var k = null;',
- 'this.DoLocal = function (o) {',
- ' var j = null;',
- ' try{',
- ' k = rtl.setIntfL(k, rtl.queryIntfT(o, $mod.IUnknown), true);',
- ' k = rtl.setIntfL(k, $mod.i);',
- ' j = rtl.setIntfL(j, rtl.queryIntfT(o, $mod.IUnknown), true);',
- ' j = rtl.setIntfL(j, $mod.i);',
- ' }finally{',
- ' rtl._Release(j);',
- ' };',
- '};',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'rtl.setIntfP($mod, "i", null);',
- 'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.o, $mod.IUnknown), true);',
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_AssignArg;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' end;',
- 'procedure DoDefault(i, j: IUnknown);',
- 'begin',
- ' i:=nil;',
- ' i:=j;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_AssignArg',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.DoDefault = function (i, j) {',
- ' rtl._AddRef(i);',
- ' try {',
- ' i = rtl.setIntfL(i, null);',
- ' i = rtl.setIntfL(i, j);',
- ' } finally {',
- ' rtl._Release(i);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_FunctionResult;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' end;',
- 'function DoDefault(i: IUnknown): IUnknown;',
- 'begin',
- ' Result:=i;',
- ' if Result<>nil then exit;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_FunctionResult',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.DoDefault = function (i) {',
- ' var Result = null;',
- ' var $ok = false;',
- ' try {',
- ' Result = rtl.setIntfL(Result, i);',
- ' if(Result !== null){',
- ' $ok = true;',
- ' return Result;',
- ' };',
- ' $ok = true;',
- ' } finally {',
- ' if(!$ok) rtl._Release(Result);',
- ' };',
- ' return Result;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_InheritedFuncResult;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' function GetIntf: IUnknown; virtual;',
- ' end;',
- ' TMouse = class',
- ' function GetIntf: IUnknown; override;',
- ' end;',
- 'function TObject.GetIntf: IUnknown; begin end;',
- 'function TMouse.GetIntf: IUnknown;',
- 'var i: IUnknown;',
- 'begin',
- ' inherited;',
- ' inherited GetIntf;',
- ' inherited GetIntf();',
- ' Result:=inherited GetIntf;',
- ' Result:=inherited GetIntf();',
- ' i:=inherited GetIntf;',
- ' i:=inherited GetIntf();',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_InheritedFuncResult',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetIntf = function () {',
- ' var Result = null;',
- ' return Result;',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'rtl.createClass(this, "TMouse", this.TObject, function () {',
- ' this.GetIntf = function () {',
- ' var Result = null;',
- ' var i = null;',
- ' var $ir = rtl.createIntfRefs();',
- ' var $ok = false;',
- ' try {',
- ' $ir.ref(1, $mod.TObject.GetIntf.call(this));',
- ' $ir.ref(2, $mod.TObject.GetIntf.call(this));',
- ' $ir.ref(3, $mod.TObject.GetIntf.call(this));',
- ' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
- ' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
- ' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
- ' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
- ' $ok = true;',
- ' } finally {',
- ' $ir.free();',
- ' rtl._Release(i);',
- ' if (!$ok) rtl._Release(Result);',
- ' };',
- ' return Result;',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_IsAsTypeCasts;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' end;',
- 'procedure DoDefault(i, j: IUnknown; o: TObject);',
- 'begin',
- ' if i is IUnknown then ;',
- ' if o is IUnknown then ;',
- ' if i is TObject then ;',
- ' i:=j as IUnknown;',
- ' i:=o as IUnknown;',
- ' o:=j as TObject;',
- ' i:=IUnknown(j);',
- ' i:=IUnknown(o);',
- ' o:=TObject(i);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_IsAsTypeCasts',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.DoDefault = function (i, j, o) {',
- ' rtl._AddRef(i);',
- ' try {',
- ' if (rtl.intfIsIntfT(i, $mod.IUnknown)) ;',
- ' if (rtl.queryIntfIsT(o, $mod.IUnknown)) ;',
- ' if (rtl.intfIsClass(i, $mod.TObject)) ;',
- ' i = rtl.setIntfL(i, rtl.intfAsIntfT(j, $mod.IUnknown));',
- ' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
- ' o = rtl.intfAsClass(j, $mod.TObject);',
- ' i = rtl.setIntfL(i, j);',
- ' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
- ' o = rtl.intfToClass(i, $mod.TObject);',
- ' } finally {',
- ' rtl._Release(i);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_PassAsArg;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' end;',
- 'procedure DoIt(v: IUnknown; const j: IUnknown; var k: IUnknown; out l: IUnknown);',
- 'var o: TObject;',
- 'begin',
- ' DoIt(v,v,v,v);',
- ' DoIt(o,o,k,k);',
- 'end;',
- 'procedure DoSome;',
- 'var v: IUnknown;',
- 'begin',
- ' DoIt(v,v,v,v);',
- 'end;',
- 'var i: IUnknown;',
- 'begin',
- ' DoIt(i,i,i,i);',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_PassAsArg',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.DoIt = function (v, j, k, l) {',
- ' var o = null;',
- ' var $ir = rtl.createIntfRefs();',
- ' rtl._AddRef(v);',
- ' try {',
- ' $mod.DoIt(v, v, {',
- ' get: function () {',
- ' return v;',
- ' },',
- ' set: function (w) {',
- ' v = rtl.setIntfL(v, w);',
- ' }',
- ' }, {',
- ' get: function () {',
- ' return v;',
- ' },',
- ' set: function (w) {',
- ' v = rtl.setIntfL(v, w);',
- ' }',
- ' });',
- ' $mod.DoIt($ir.ref(1, rtl.queryIntfT(o, $mod.IUnknown)), $ir.ref(2, rtl.queryIntfT(o, $mod.IUnknown)), k, k);',
- ' } finally {',
- ' $ir.free();',
- ' rtl._Release(v);',
- ' };',
- '};',
- 'this.DoSome = function () {',
- ' var v = null;',
- ' try {',
- ' $mod.DoIt(v, v, {',
- ' get: function () {',
- ' return v;',
- ' },',
- ' set: function (w) {',
- ' v = rtl.setIntfL(v, w);',
- ' }',
- ' }, {',
- ' get: function () {',
- ' return v;',
- ' },',
- ' set: function (w) {',
- ' v = rtl.setIntfL(v, w);',
- ' }',
- ' });',
- ' } finally {',
- ' rtl._Release(v);',
- ' };',
- '};',
- 'this.i = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.i, $mod.i, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' rtl.setIntfP(this.p, "i", v);',
- ' }',
- '}, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' rtl.setIntfP(this.p, "i", v);',
- ' }',
- '});',
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_PassToUntypedParam;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' end;',
- 'procedure DoIt(out i);',
- 'begin end;',
- 'procedure DoSome;',
- 'var v: IUnknown;',
- 'begin',
- ' DoIt(v);',
- 'end;',
- 'function GetIt: IUnknown;',
- 'begin',
- ' DoIt(Result);',
- 'end;',
- 'var i: IUnknown;',
- 'begin',
- ' DoIt(i);',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_PassToUntypedParam',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.DoIt = function (i) {',
- '};',
- 'this.DoSome = function () {',
- ' var v = null;',
- ' try {',
- ' $mod.DoIt({',
- ' get: function () {',
- ' return v;',
- ' },',
- ' set: function (w) {',
- ' v = w;',
- ' }',
- ' });',
- ' } finally {',
- ' rtl._Release(v);',
- ' };',
- '};',
- 'this.GetIt = function () {',
- ' var Result = null;',
- ' var $ok = false;',
- ' try {',
- ' $mod.DoIt({',
- ' get: function () {',
- ' return Result;',
- ' },',
- ' set: function (v) {',
- ' Result = v;',
- ' }',
- ' });',
- ' $ok = true;',
- ' } finally {',
- ' if (!$ok) rtl._Release(Result);',
- ' };',
- ' return Result;',
- '};',
- 'this.i = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'try {',
- ' $mod.DoIt({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- ' });',
- '} finally {',
- ' rtl._Release($mod.i);',
- '};',
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_FunctionInExpr;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' end;',
- 'function GetIt: IUnknown;',
- 'begin',
- 'end;',
- 'procedure DoSome;',
- 'var v: IUnknown;',
- ' i: longint;',
- 'begin',
- ' v:=GetIt;',
- ' v:=GetIt();',
- ' GetIt()._AddRef;',
- ' i:=GetIt()._AddRef;',
- 'end;',
- 'var v: IUnknown;',
- ' i: longint;',
- 'begin',
- ' v:=GetIt;',
- ' v:=GetIt();',
- ' GetIt()._AddRef;',
- ' i:=GetIt()._AddRef;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_FunctionInExpr',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.GetIt = function () {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.DoSome = function () {',
- ' var v = null;',
- ' var i = 0;',
- ' var $ir = rtl.createIntfRefs();',
- ' try {',
- ' v = rtl.setIntfL(v, $mod.GetIt(), true);',
- ' v = rtl.setIntfL(v, $mod.GetIt(), true);',
- ' $ir.ref(1, $mod.GetIt())._AddRef();',
- ' i = $ir.ref(2, $mod.GetIt())._AddRef();',
- ' } finally {',
- ' $ir.free();',
- ' rtl._Release(v);',
- ' };',
- '};',
- 'this.v = null;',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- 'var $ir = rtl.createIntfRefs();',
- 'try {',
- ' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
- ' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
- ' $ir.ref(1, $mod.GetIt())._AddRef();',
- ' $mod.i = $ir.ref(2, $mod.GetIt())._AddRef();',
- '} finally {',
- ' $ir.free();',
- '};',
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_Property;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' FAnt: IUnknown;',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' function GetBird: IUnknown; virtual; abstract;',
- ' procedure SetBird(Value: IUnknown); virtual; abstract;',
- ' function GetItems(Index: longint): IUnknown; virtual; abstract;',
- ' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
- ' property Ant: IUnknown read FAnt write FAnt;',
- ' property Bird: IUnknown read GetBird write SetBird;',
- ' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
- ' end;',
- 'procedure DoIt;',
- 'var',
- ' o: TObject;',
- ' v: IUnknown;',
- 'begin',
- ' v:=o.Ant;',
- ' o.Ant:=v;',
- ' o.Ant:=o.Ant;',
- ' v:=o.Bird;',
- ' o.Bird:=v;',
- ' o.Bird:=o.Bird;',
- ' v:=o.Items[1];',
- ' o.Items[2]:=v;',
- ' o.Items[3]:=o.Items[4];',
- ' v:=o[5];',
- ' o[6]:=v;',
- ' o[7]:=o[8];',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_Property',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FAnt = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FAnt = undefined;',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.DoIt = function () {',
- ' var o = null;',
- ' var v = null;',
- ' var $ir = rtl.createIntfRefs();',
- ' try {',
- ' v = rtl.setIntfL(v, o.FAnt);',
- ' rtl.setIntfP(o, "FAnt", v);',
- ' rtl.setIntfP(o, "FAnt", o.FAnt);',
- ' v = rtl.setIntfL(v, o.GetBird(), true);',
- ' o.SetBird(v);',
- ' o.SetBird($ir.ref(1, o.GetBird()));',
- ' v = rtl.setIntfL(v, o.GetItems(1), true);',
- ' o.SetItems(2, v);',
- ' o.SetItems(3, $ir.ref(2, o.GetItems(4)));',
- ' v = rtl.setIntfL(v, o.GetItems(5), true);',
- ' o.SetItems(6, v);',
- ' o.SetItems(7, $ir.ref(3, o.GetItems(8)));',
- ' } finally {',
- ' $ir.free();',
- ' rtl._Release(v);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_IntfProperty;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' function GetBird: IUnknown;',
- ' procedure SetBird(Value: IUnknown);',
- ' function GetItems(Index: longint): IUnknown;',
- ' procedure SetItems(Index: longint; Value: IUnknown);',
- ' property Bird: IUnknown read GetBird write SetBird;',
- ' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' function GetBird: IUnknown; virtual; abstract;',
- ' procedure SetBird(Value: IUnknown); virtual; abstract;',
- ' function GetItems(Index: longint): IUnknown; virtual; abstract;',
- ' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
- ' end;',
- 'procedure DoIt;',
- 'var',
- ' o: TObject;',
- ' v: IUnknown;',
- 'begin',
- ' v:=v.Items[1];',
- ' v.Items[2]:=v;',
- ' v.Items[3]:=v.Items[4];',
- ' v:=v[5];',
- ' v[6]:=v;',
- ' v[7]:=v[8];',
- ' v[9].Bird.Bird:=v;',
- ' v:=v.Bird[10].Bird',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_IntfProperty',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{385F5482-571B-338C-8130-4E97F330543B}", [',
- ' "_AddRef",',
- ' "_Release",',
- ' "GetBird",',
- ' "SetBird",',
- ' "GetItems",',
- ' "SetItems"',
- '], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.DoIt = function () {',
- ' var o = null;',
- ' var v = null;',
- ' var $ir = rtl.createIntfRefs();',
- ' try {',
- ' v = rtl.setIntfL(v, v.GetItems(1), true);',
- ' v.SetItems(2, v);',
- ' v.SetItems(3, $ir.ref(1, v.GetItems(4)));',
- ' v = rtl.setIntfL(v, v.GetItems(5), true);',
- ' v.SetItems(6, v);',
- ' v.SetItems(7, $ir.ref(2, v.GetItems(8)));',
- ' $ir.ref(4, $ir.ref(3, v.GetItems(9)).GetBird()).SetBird(v);',
- ' v = rtl.setIntfL(v, $ir.ref(6, $ir.ref(5, v.GetBird()).GetItems(10)).GetBird(), true);',
- ' } finally {',
- ' $ir.free();',
- ' rtl._Release(v);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_Delegation;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' IBird = interface(IUnknown)',
- ' procedure Fly(s: string);',
- ' end;',
- ' IEagle = interface(IBird) end;',
- ' IDove = interface(IBird) end;',
- ' ISwallow = interface(IBird) end;',
- ' TObject = class',
- ' end;',
- ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' procedure Fly(s: string); virtual; abstract;',
- ' end;',
- ' TBat = class(IBird,IEagle,IDove,ISwallow)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' FBirdIntf: IBird;',
- ' property BirdIntf: IBird read FBirdIntf implements IBird;',
- ' function GetEagleIntf: IEagle; virtual; abstract;',
- ' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
- ' FDoveObj: TBird;',
- ' property DoveObj: TBird read FDoveObj implements IDove;',
- ' function GetSwallowObj: TBird; virtual; abstract;',
- ' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_Delegation',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createInterface(this, "IBird", "{CC440C7F-7623-3DEE-AE88-000B86AAF108}", ["Fly"], this.IUnknown);',
- 'rtl.createInterface(this, "IEagle", "{4B6A41C9-B020-3D7C-B688-96D19022B1B4}", [], this.IBird);',
- 'rtl.createInterface(this, "IDove", "{4B6A41C9-B020-3D7C-B688-96D18EF16074}", [], this.IBird);',
- 'rtl.createInterface(this, "ISwallow", "{BB6A41C9-B020-3D7C-B688-96D1CBDCB359}", [], this.IBird);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.addIntf(this, $mod.IBird);',
- ' rtl.addIntf(this, $mod.IEagle);',
- ' rtl.addIntf(this, $mod.IDove);',
- ' rtl.addIntf(this, $mod.ISwallow);',
- '});',
- 'rtl.createClass(this, "TBat", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FBirdIntf = null;',
- ' this.FDoveObj = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FBirdIntf = undefined;',
- ' this.FDoveObj = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- ' this.$intfmaps = {',
- ' "{CC440C7F-7623-3DEE-AE88-000B86AAF108}": function () {',
- ' return rtl._AddRef(this.FBirdIntf);',
- ' },',
- ' "{4B6A41C9-B020-3D7C-B688-96D19022B1B4}": function () {',
- ' return this.GetEagleIntf();',
- ' },',
- ' "{4B6A41C9-B020-3D7C-B688-96D18EF16074}": function () {',
- ' return rtl.queryIntfT(this.FDoveObj, $mod.IDove);',
- ' },',
- ' "{BB6A41C9-B020-3D7C-B688-96D1CBDCB359}": function () {',
- ' return rtl.queryIntfT(this.GetSwallowObj(), $mod.ISwallow);',
- ' }',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_With;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' function GetAnt: IUnknown;',
- ' property Ant: IUnknown read GetAnt;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' function GetAnt: IUnknown; virtual; abstract;',
- ' property Ant: IUnknown read GetAnt;',
- ' end;',
- 'procedure DoIt;',
- 'var',
- ' i: IUnknown;',
- 'begin',
- ' with i do ',
- ' GetAnt;',
- ' with i.Ant, Ant do ',
- ' GetAnt;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_With',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB00D-C6B6-39FB-BDDF-21CD521DDFA9}", ["_AddRef", "_Release", "GetAnt"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.DoIt = function () {',
- ' var i = null;',
- ' var $ir = rtl.createIntfRefs();',
- ' try {',
- ' $ir.ref(1, i.GetAnt());',
- ' var $with = $ir.ref(2, i.GetAnt());',
- ' var $with1 = $ir.ref(3, $with.GetAnt());',
- ' $ir.ref(4, $with1.GetAnt());',
- ' } finally {',
- ' $ir.free();',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ForIn;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface end;',
- ' TObject = class',
- ' Id: longint;',
- ' end;',
- ' IEnumerator = interface(IUnknown)',
- ' function GetCurrent: TObject;',
- ' function MoveNext: Boolean;',
- ' property Current: TObject read GetCurrent;',
- ' end;',
- ' IEnumerable = interface(IUnknown)',
- ' function GetEnumerator: IEnumerator;',
- ' end;',
- 'var',
- ' o: TObject;',
- ' i: IEnumerable;',
- 'begin',
- ' for o in i do o.Id:=3;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ForIn',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Id = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createInterface(this, "IEnumerator", "{95D7745D-ED61-3F13-BBE4-07708161999E}", ["GetCurrent", "MoveNext"], this.IUnknown);',
- 'rtl.createInterface(this, "IEnumerable", "{8CC9D45D-ED7D-3B73-96B6-290B931BB19E}", ["GetEnumerator"], this.IUnknown);',
- 'this.o = null;',
- 'this.i = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'var $in = $mod.i.GetEnumerator();',
- 'try {',
- ' while ($in.MoveNext()) {',
- ' $mod.o = $in.GetCurrent();',
- ' $mod.o.Id = 3;',
- ' }',
- '} finally {',
- ' rtl._Release($in)',
- '};',
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntfFail;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TArrOfIntf = array of IUnknown;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Not supported: array of COM-interface',nNotSupportedX);
- ConvertProgram;
- end;
- procedure TTestModule.TestClassInterface_COM_RecordIntfFail;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TRec = record',
- ' i: IUnknown;',
- ' end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Not supported: COM-interface as record member',nNotSupportedX);
- ConvertProgram;
- end;
- procedure TTestModule.TestClassInterface_COM_UnitInitialization;
- begin
- StartUnit(false);
- Add([
- '{$interfaces com}',
- 'interface',
- 'implementation',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint;',
- ' end;',
- 'function TObject._AddRef: longint; begin end;',
- 'var i: IUnknown;',
- ' o: TObject;',
- 'initialization',
- ' i:=nil;',
- ' i:=i;',
- ' i:=o;',
- ' if (o as IUnknown)=nil then ;',
- '']);
- ConvertUnit;
- CheckSource('TestClassInterface_COM_UnitInitialization',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- '']),
- LinesToStr([ // this.$init
- 'var $ir = rtl.createIntfRefs();',
- 'try {',
- ' rtl.setIntfP($impl, "i", null);',
- ' rtl.setIntfP($impl, "i", $impl.i);',
- ' rtl.setIntfP($impl, "i", rtl.queryIntfT($impl.o, $impl.IUnknown), true);',
- ' if ($ir.ref(1, rtl.queryIntfT($impl.o, $impl.IUnknown)) === null) ;',
- '} finally {',
- ' $ir.free();',
- '};',
- '']),
- LinesToStr([ // implementation
- 'rtl.createInterface($impl, "IUnknown", "{B92D5841-758A-322B-BDDF-21CD52180000}", ["_AddRef"], null);',
- 'rtl.createClass($impl, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this._AddRef = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' rtl.addIntf(this, $impl.IUnknown);',
- '});',
- '$impl.i = null;',
- '$impl.o = null;',
- ''])
- );
- end;
- procedure TTestModule.TestClassInterface_GUID;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
- ' end;',
- ' TObject = class end;',
- ' TGUID = record D1, D2, D3, D4: word; end;',
- ' TAliasGUID = TGUID;',
- ' TGUIDString = type string;',
- ' TAliasGUIDString = TGUIDString;',
- 'procedure DoConstGUIDIt(const g: TAliasGUID); overload;',
- 'begin end;',
- 'procedure DoDefGUID(g: TAliasGUID); overload;',
- 'begin end;',
- 'procedure DoStr(const s: TAliasGUIDString); overload;',
- 'begin end;',
- 'var',
- ' i: IUnknown;',
- ' g: TAliasGUID = ''{d91c9af4-3C93-420F-A303-BF5BA82BFD23}'';',
- ' s: TAliasGUIDString;',
- 'begin',
- ' DoConstGUIDIt(IUnknown);',
- ' DoDefGUID(IUnknown);',
- ' DoStr(IUnknown);',
- ' DoConstGUIDIt(i);',
- ' DoDefGUID(i);',
- ' DoStr(i);',
- ' DoConstGUIDIt(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
- ' DoDefGUID(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
- ' DoStr(g);',
- ' g:=i;',
- ' g:=IUnknown;',
- ' g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
- ' s:=i;',
- ' s:=IUnknown;',
- ' s:=g;',
- ' if g=i then ;',
- ' if i=g then ;',
- ' if g=IUnknown then ;',
- ' if IUnknown=g then ;',
- ' if s=i then ;',
- ' if i=s then ;',
- ' if s=IUnknown then ;',
- ' if IUnknown=s then ;',
- ' if s=g then ;',
- ' if g=s then ;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_GUID',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.recNewT(this, "TGUID", function () {',
- ' this.D1 = 0;',
- ' this.D2 = 0;',
- ' this.D3 = 0;',
- ' this.D4 = 0;',
- ' this.$eq = function (b) {',
- ' return (this.D1 === b.D1) && (this.D2 === b.D2) && (this.D3 === b.D3) && (this.D4 === b.D4);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.D1 = s.D1;',
- ' this.D2 = s.D2;',
- ' this.D3 = s.D3;',
- ' this.D4 = s.D4;',
- ' return this;',
- ' };',
- '});',
- 'this.DoConstGUIDIt = function (g) {',
- '};',
- 'this.DoDefGUID = function (g) {',
- '};',
- 'this.DoStr = function (s) {',
- '};',
- 'this.i = null;',
- 'this.g = this.TGUID.$clone({',
- ' D1: 0xD91C9AF4,',
- ' D2: 0x3C93,',
- ' D3: 0x420F,',
- ' D4: [',
- ' 0xA3,',
- ' 0x03,',
- ' 0xBF,',
- ' 0x5B,',
- ' 0xA8,',
- ' 0x2B,',
- ' 0xFD,',
- ' 0x23',
- ' ]',
- '});',
- 'this.s = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.IUnknown));',
- '$mod.DoDefGUID($mod.TGUID.$clone(rtl.getIntfGUIDR($mod.IUnknown)));',
- '$mod.DoStr($mod.IUnknown.$guid);',
- '$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.i));',
- '$mod.DoDefGUID($mod.TGUID.$clone(rtl.getIntfGUIDR($mod.i)));',
- '$mod.DoStr($mod.i.$guid);',
- '$mod.DoConstGUIDIt(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
- '$mod.DoDefGUID(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
- '$mod.DoStr(rtl.guidrToStr($mod.g));',
- '$mod.g.$assign(rtl.getIntfGUIDR($mod.i));',
- '$mod.g.$assign(rtl.getIntfGUIDR($mod.IUnknown));',
- '$mod.g.$assign({',
- ' D1: 0xD91C9AF4,',
- ' D2: 0x3C93,',
- ' D3: 0x420F,',
- ' D4: [',
- ' 0xA3,',
- ' 0x03,',
- ' 0xBF,',
- ' 0x5B,',
- ' 0xA8,',
- ' 0x2B,',
- ' 0xFD,',
- ' 0x23',
- ' ]',
- '});',
- '$mod.s = $mod.i.$guid;',
- '$mod.s = $mod.IUnknown.$guid;',
- '$mod.s = rtl.guidrToStr($mod.g);',
- 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.i))) ;',
- 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.i))) ;',
- 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.IUnknown))) ;',
- 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.IUnknown))) ;',
- 'if ($mod.s === $mod.i.$guid) ;',
- 'if ($mod.i.$guid === $mod.s) ;',
- 'if ($mod.s === $mod.IUnknown.$guid) ;',
- 'if ($mod.IUnknown.$guid === $mod.s) ;',
- 'if ($mod.g.$eq(rtl.createTGUID($mod.s))) ;',
- 'if ($mod.g.$eq(rtl.createTGUID($mod.s))) ;',
- '']));
- end;
- procedure TTestModule.TestClassInterface_GUIDProperty;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface',
- ' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
- ' end;',
- ' TGUID = record D1, D2, D3, D4: word; end;',
- ' TAliasGUID = TGUID;',
- ' TGUIDString = type string;',
- ' TAliasGUIDString = TGUIDString;',
- ' TObject = class',
- ' function GetG: TAliasGUID; virtual; abstract;',
- ' procedure SetG(const Value: TAliasGUID); virtual; abstract;',
- ' function GetS: TAliasGUIDString; virtual; abstract;',
- ' procedure SetS(const Value: TAliasGUIDString); virtual; abstract;',
- ' property g: TAliasGUID read GetG write SetG;',
- ' property s: TAliasGUIDString read GetS write SetS;',
- ' end;',
- 'var o: TObject;',
- 'begin',
- ' o.g:=IUnknown;',
- ' o.g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
- ' o.s:=IUnknown;',
- ' o.s:=o.g;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_GUIDProperty',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
- 'rtl.recNewT(this, "TGUID", function () {',
- ' this.D1 = 0;',
- ' this.D2 = 0;',
- ' this.D3 = 0;',
- ' this.D4 = 0;',
- ' this.$eq = function (b) {',
- ' return (this.D1 === b.D1) && (this.D2 === b.D2) && (this.D3 === b.D3) && (this.D4 === b.D4);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.D1 = s.D1;',
- ' this.D2 = s.D2;',
- ' this.D3 = s.D3;',
- ' this.D4 = s.D4;',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.o.SetG(rtl.getIntfGUIDR($mod.IUnknown));',
- '$mod.o.SetG({',
- ' D1: 0xD91C9AF4,',
- ' D2: 0x3C93,',
- ' D3: 0x420F,',
- ' D4: [',
- ' 0xA3,',
- ' 0x03,',
- ' 0xBF,',
- ' 0x5B,',
- ' 0xA8,',
- ' 0x2B,',
- ' 0xFD,',
- ' 0x23',
- ' ]',
- '});',
- '$mod.o.SetS($mod.IUnknown.$guid);',
- '$mod.o.SetS(rtl.guidrToStr($mod.o.GetG()));',
- '']));
- end;
- procedure TTestModule.TestClassHelper_ClassVar;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' end;',
- ' THelper = class helper for TObject',
- ' const',
- ' One = 1;',
- ' Two: word = 2;',
- ' class var',
- ' Glob: word;',
- ' function Foo(w: word): word;',
- ' class function Bar(w: word): word;',
- ' end;',
- 'function THelper.foo(w: word): word;',
- 'begin',
- ' Result:=w;',
- ' Two:=One+w;',
- ' Glob:=Glob;',
- ' Result:=Self.Glob;',
- ' Self.Glob:=Self.Glob;',
- ' with Self do Glob:=Glob;',
- 'end;',
- 'class function THelper.bar(w: word): word;',
- 'begin',
- ' Result:=w;',
- ' Two:=One;',
- ' Glob:=Glob;',
- ' Self.Glob:=Self.Glob;',
- ' with Self do Glob:=Glob;',
- 'end;',
- 'var o: TObject;',
- 'begin',
- ' tobject.two:=tobject.one;',
- ' tobject.Glob:=tobject.Glob;',
- ' with tobject do begin',
- ' two:=one;',
- ' Glob:=Glob;',
- ' end;',
- ' o.two:=o.one;',
- ' o.Glob:=o.Glob;',
- ' with o do begin',
- ' two:=one;',
- ' Glob:=Glob;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_ClassVar',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.One = 1;',
- ' this.Two = 2;',
- ' this.Glob = 0;',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' Result = w;',
- ' $mod.THelper.Two = 1 + w;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' Result = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' return Result;',
- ' };',
- ' this.Bar = function (w) {',
- ' var Result = 0;',
- ' Result = w;',
- ' $mod.THelper.Two = 1;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' return Result;',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- 'var $with = $mod.TObject;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- 'var $with1 = $mod.o;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '']));
- end;
- procedure TTestModule.TestClassHelper_Method_AccessInstanceFields;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' FSize: word;',
- ' property Size: word read FSize write FSize;',
- ' end;',
- ' THelper = class helper for TObject',
- ' function Foo(w: word = 1): word;',
- ' end;',
- 'function THelper.foo(w: word): word;',
- 'begin',
- ' Result:=Size;',
- ' Size:=Size+2;',
- ' Self.Size:=Self.Size+3;',
- ' FSize:=FSize+4;',
- ' Self.FSize:=Self.FSize+5;',
- ' with Self do begin',
- ' Size:=Size+6;',
- ' FSize:=FSize+7;',
- ' FSize:=FSize+8;',
- ' end;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_Method_AccessInstanceFields',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FSize = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' Result = this.FSize;',
- ' this.FSize = this.FSize + 2;',
- ' this.FSize = this.FSize + 3;',
- ' this.FSize = this.FSize + 4;',
- ' this.FSize = this.FSize + 5;',
- ' this.FSize = this.FSize + 6;',
- ' this.FSize = this.FSize + 7;',
- ' this.FSize = this.FSize + 8;',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassHelper_Method_Call;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure Run(w: word = 10);',
- ' end;',
- ' THelper = class helper for TObject',
- ' function Foo(w: word = 1): word;',
- ' end;',
- 'procedure TObject.Run(w: word);',
- 'var o: TObject;',
- 'begin',
- ' Foo;',
- ' Foo();',
- ' Foo(2);',
- ' Self.Foo;',
- ' Self.Foo();',
- ' Self.Foo(3);',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' Foo(4);',
- ' end;',
- ' with o do Foo(5);',
- 'end;',
- 'function THelper.foo(w: word): word;',
- 'begin',
- ' Run;',
- ' Run();',
- ' Run(11);',
- ' Foo;',
- ' Foo();',
- ' Foo(12);',
- ' Self.Foo;',
- ' Self.Foo();',
- ' Self.Foo(13);',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' Foo(14);',
- ' end;',
- 'end;',
- 'var Obj: TObject;',
- 'begin',
- ' obj.Foo;',
- ' obj.Foo();',
- ' obj.Foo(21);',
- ' with obj do begin',
- ' Foo;',
- ' Foo();',
- ' Foo(22);',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_Method_Call',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Run = function (w) {',
- ' var o = null;',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 2);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 3);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 4);',
- ' $mod.THelper.Foo.call(o, 5);',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' this.Run(10);',
- ' this.Run(10);',
- ' this.Run(11);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 12);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 13);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 14);',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Foo.call($mod.Obj, 1);',
- '$mod.THelper.Foo.call($mod.Obj, 1);',
- '$mod.THelper.Foo.call($mod.Obj, 21);',
- 'var $with = $mod.Obj;',
- '$mod.THelper.Foo.call($with, 1);',
- '$mod.THelper.Foo.call($with, 1);',
- '$mod.THelper.Foo.call($with, 22);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_Method_Nested_Call;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure Run(w: word = 10);',
- ' end;',
- ' THelper = class helper for TObject',
- ' function Foo(w: word = 1): word;',
- ' end;',
- 'procedure TObject.Run(w: word);',
- ' procedure Sub(Self: TObject);',
- ' begin',
- ' Foo;',
- ' Foo();',
- ' Self.Foo;',
- ' Self.Foo();',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' end;',
- ' end;',
- 'begin',
- 'end;',
- 'function THelper.foo(w: word): word;',
- ' procedure Sub(Self: TObject);',
- ' begin',
- ' Run;',
- ' Run();',
- ' Foo;',
- ' Foo();',
- ' Self.Foo;',
- ' Self.Foo();',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' end;',
- ' end;',
- 'begin',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_Method_Nested_Call',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Run = function (w) {',
- ' var $Self = this;',
- ' function Sub(Self) {',
- ' $mod.THelper.Foo.call($Self, 1);',
- ' $mod.THelper.Foo.call($Self, 1);',
- ' $mod.THelper.Foo.call(Self, 1);',
- ' $mod.THelper.Foo.call(Self, 1);',
- ' $mod.THelper.Foo.call(Self, 1);',
- ' $mod.THelper.Foo.call(Self, 1);',
- ' };',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Foo = function (w) {',
- ' var $Self = this;',
- ' var Result = 0;',
- ' function Sub(Self) {',
- ' $Self.Run(10);',
- ' $Self.Run(10);',
- ' $mod.THelper.Foo.call($Self, 1);',
- ' $mod.THelper.Foo.call($Self, 1);',
- ' $mod.THelper.Foo.call(Self, 1);',
- ' $mod.THelper.Foo.call(Self, 1);',
- ' $mod.THelper.Foo.call(Self, 1);',
- ' $mod.THelper.Foo.call(Self, 1);',
- ' };',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassHelper_ClassMethod_Call;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' class procedure Run(w: word = 10);',
- ' end;',
- ' THelper = class helper for TObject',
- ' class function Foo(w: word = 1): word;',
- ' end;',
- 'class procedure TObject.Run(w: word);',
- 'begin',
- ' Foo;',
- ' Foo();',
- ' Self.Foo;',
- ' Self.Foo();',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' end;',
- 'end;',
- 'class function THelper.foo(w: word): word;',
- 'begin',
- ' Run;',
- ' Run();',
- ' Foo;',
- ' Foo();',
- ' Self.Foo;',
- ' Self.Foo();',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' end;',
- 'end;',
- 'var',
- ' Obj: TObject;',
- 'begin',
- ' obj.Foo;',
- ' obj.Foo();',
- ' with obj do begin',
- ' Foo;',
- ' Foo();',
- ' end;',
- ' tobject.Foo;',
- ' tobject.Foo();',
- ' with tobject do begin',
- ' Foo;',
- ' Foo();',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_ClassMethod_Call',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Run = function (w) {',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' this.Run(10);',
- ' this.Run(10);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Foo.call($mod.Obj.$class, 1);',
- '$mod.THelper.Foo.call($mod.Obj.$class, 1);',
- 'var $with = $mod.Obj;',
- '$mod.THelper.Foo.call($with.$class, 1);',
- '$mod.THelper.Foo.call($with.$class, 1);',
- '$mod.THelper.Foo.call($mod.TObject, 1);',
- '$mod.THelper.Foo.call($mod.TObject, 1);',
- 'var $with1 = $mod.TObject;',
- '$mod.THelper.Foo.call($mod.TObject, 1);',
- '$mod.THelper.Foo.call($mod.TObject, 1);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_ClassOf;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' end;',
- ' TClass = class of TObject;',
- ' THelper = class helper for TObject',
- ' class function Foo(w: word = 1): word;',
- ' end;',
- 'class function THelper.foo(w: word): word;',
- 'begin',
- 'end;',
- 'var',
- ' c: TClass;',
- 'begin',
- ' c.Foo;',
- ' c.Foo();',
- ' with c do begin',
- ' Foo;',
- ' Foo();',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_ClassOf',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'this.c = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Foo.call($mod.c, 1);',
- '$mod.THelper.Foo.call($mod.c, 1);',
- 'var $with = $mod.c;',
- '$mod.THelper.Foo.call($with, 1);',
- '$mod.THelper.Foo.call($with, 1);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_MethodRefObjFPC;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- 'type',
- ' TObject = class',
- ' procedure DoIt;',
- ' end;',
- ' THelper = class helper for TObject',
- ' procedure Fly(w: word = 1);',
- ' class procedure Glide(w: word = 1);',
- ' class procedure Run(w: word = 1); static;',
- ' end;',
- ' TFly = procedure(w: word) of object;',
- ' TGlide = TFly;',
- ' TRun = procedure(w: word);',
- 'var',
- ' f: TFly;',
- ' g: TGlide;',
- ' r: TRun;',
- 'procedure TObject.DoIt;',
- 'begin',
- ' f:=@fly;',
- ' g:=@glide;',
- ' r:=@run;',
- ' f:[email protected];',
- ' g:[email protected];',
- ' r:[email protected];',
- ' with self do begin',
- ' f:=@fly;',
- ' g:=@glide;',
- ' r:=@run;',
- ' end;',
- 'end;',
- 'procedure THelper.fly(w: word);',
- 'begin',
- ' f:=@fly;',
- ' g:=@glide;',
- ' r:=@run;',
- 'end;',
- 'class procedure THelper.glide(w: word);',
- 'begin',
- ' g:=@glide;',
- ' r:=@run;',
- 'end;',
- 'class procedure THelper.run(w: word);',
- 'begin',
- ' g:=@glide;',
- ' r:=@run;',
- 'end;',
- 'var',
- ' Obj: TObject;',
- 'begin',
- ' f:[email protected];',
- ' g:[email protected];',
- ' r:[email protected];',
- ' with obj do begin',
- ' f:=@fly;',
- ' g:=@glide;',
- ' r:=@run;',
- ' end;',
- ' g:[email protected];',
- ' r:[email protected];',
- ' with tobject do begin',
- ' g:=@glide;',
- ' r:=@run;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_MethodRefObjFPC',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
- ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
- ' $mod.r = $mod.THelper.Run;',
- ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
- ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
- ' $mod.r = $mod.THelper.Run;',
- ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
- ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
- ' $mod.r = $mod.THelper.Run;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Fly = function (w) {',
- ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
- ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
- ' $mod.r = $mod.THelper.Run;',
- ' };',
- ' this.Glide = function (w) {',
- ' $mod.g = rtl.createCallback(this, $mod.THelper.Glide);',
- ' $mod.r = $mod.THelper.Run;',
- ' };',
- ' this.Run = function (w) {',
- ' $mod.g = rtl.createCallback($mod.THelper, $mod.THelper.Glide);',
- ' $mod.r = $mod.THelper.Run;',
- ' };',
- '});',
- 'this.f = null;',
- 'this.g = null;',
- 'this.r = null;',
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.f = rtl.createCallback($mod.Obj, $mod.THelper.Fly);',
- '$mod.g = rtl.createCallback($mod.Obj.$class, $mod.THelper.Glide);',
- '$mod.r = $mod.THelper.Run;',
- 'var $with = $mod.Obj;',
- '$mod.f = rtl.createCallback($with, $mod.THelper.Fly);',
- '$mod.g = rtl.createCallback($with.$class, $mod.THelper.Glide);',
- '$mod.r = $mod.THelper.Run;',
- '$mod.g = rtl.createCallback($mod.TObject, $mod.THelper.Glide);',
- '$mod.r = $mod.THelper.Run;',
- 'var $with1 = $mod.TObject;',
- '$mod.g = rtl.createCallback($with1, $mod.THelper.Glide);',
- '$mod.r = $mod.THelper.Run;',
- '']));
- end;
- procedure TTestModule.TestClassHelper_Constructor;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- ' TClass = class of TObject;',
- ' THelper = class helper for TObject',
- ' constructor NewHlp(w: word);',
- ' end;',
- 'var',
- ' obj: TObject;',
- ' c: TClass;',
- 'constructor TObject.Create;',
- 'begin',
- ' NewHlp(2);', // normal call
- ' tobject.NewHlp(3);', // new instance
- ' c.newhlp(4);', // new instance
- 'end;',
- 'constructor THelper.NewHlp(w: word);',
- 'begin',
- ' create;', // normal call
- ' tobject.create;', // new instance
- ' NewHlp(2);', // normal call
- ' tobject.NewHlp(3);', // new instance
- ' c.newhlp(4);', // new instance
- 'end;',
- 'begin',
- ' obj.newhlp(2);', // normal call
- ' with Obj do newhlp(12);', // normal call
- ' tobject.newhlp(3);', // new instance
- ' with tobject do newhlp(13);', // new instance
- ' c.newhlp(4);', // new instance
- ' with c do newhlp(14);', // new instance
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_Constructor',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' $mod.THelper.NewHlp.call(this, 2);',
- ' $mod.TObject.$create($mod.THelper.NewHlp, [3]);',
- ' $mod.c.$create($mod.THelper.NewHlp, [4]);',
- ' return this;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.NewHlp = function (w) {',
- ' this.Create();',
- ' $mod.TObject.$create("Create");',
- ' $mod.THelper.NewHlp.call(this, 2);',
- ' $mod.TObject.$create($mod.THelper.NewHlp, [3]);',
- ' $mod.c.$create($mod.THelper.NewHlp, [4]);',
- ' return this;',
- ' };',
- '});',
- 'this.obj = null;',
- 'this.c = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.NewHlp.call($mod.obj, 2);',
- 'var $with = $mod.obj;',
- '$mod.THelper.NewHlp.call($with, 12);',
- '$mod.TObject.$create($mod.THelper.NewHlp, [3]);',
- 'var $with1 = $mod.TObject;',
- '$with1.$create($mod.THelper.NewHlp, [13]);',
- '$mod.c.$create($mod.THelper.NewHlp, [4]);',
- 'var $with2 = $mod.c;',
- '$with2.$create($mod.THelper.NewHlp, [14]);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_InheritedObjFPC;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure Fly;',
- ' end;',
- ' TObjHelper = class helper for TObject',
- ' procedure Fly;',
- ' end;',
- ' TBird = class',
- ' procedure Fly;',
- ' end;',
- ' TBirdHelper = class helper for TBird',
- ' procedure Fly;',
- ' procedure Walk(w: word);',
- ' end;',
- ' TEagleHelper = class helper(TBirdHelper) for TBird',
- ' procedure Fly;',
- ' procedure Walk(w: word);',
- ' end;',
- 'procedure Tobject.fly;',
- 'begin',
- ' inherited;', // ignore
- 'end;',
- 'procedure Tobjhelper.fly;',
- 'begin',
- ' {@TObject_Fly}inherited;',
- ' inherited {@TObject_Fly}Fly;',
- 'end;',
- 'procedure Tbird.fly;',
- 'begin',
- ' {@TObjHelper_Fly}inherited;',
- ' inherited {@TObjHelper_Fly}Fly;',
- 'end;',
- 'procedure Tbirdhelper.fly;',
- 'begin',
- ' {@TBird_Fly}inherited;',
- ' inherited {@TBird_Fly}Fly;',
- 'end;',
- 'procedure Tbirdhelper.walk(w: word);',
- 'begin',
- 'end;',
- 'procedure teagleHelper.fly;',
- 'begin',
- ' {@TBird_Fly}inherited;',
- ' inherited {@TBird_Fly}Fly;',
- 'end;',
- 'procedure teagleHelper.walk(w: word);',
- 'begin',
- ' {@TBirdHelper_Walk}inherited;',
- ' inherited {@TBirdHelper_Walk}Walk(3);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_InheritedObjFPC',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Fly = function () {',
- ' };',
- '});',
- 'rtl.createHelper(this, "TObjHelper", null, function () {',
- ' this.Fly = function () {',
- ' $mod.TObject.Fly.call(this);',
- ' $mod.TObject.Fly.call(this);',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Fly$1 = function () {',
- ' $mod.TObjHelper.Fly.call(this);',
- ' $mod.TObjHelper.Fly.call(this);',
- ' };',
- '});',
- 'rtl.createHelper(this, "TBirdHelper", null, function () {',
- ' this.Fly = function () {',
- ' $mod.TBird.Fly$1.call(this);',
- ' $mod.TBird.Fly$1.call(this);',
- ' };',
- ' this.Walk = function (w) {',
- ' };',
- '});',
- 'rtl.createHelper(this, "TEagleHelper", this.TBirdHelper, function () {',
- ' this.Fly$1 = function () {',
- ' $mod.TBird.Fly$1.call(this);',
- ' $mod.TBird.Fly$1.call(this);',
- ' };',
- ' this.Walk$1 = function (w) {',
- ' $mod.TBirdHelper.Walk.apply(this, arguments);',
- ' $mod.TBirdHelper.Walk.call(this, 3);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassHelper_Property;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' FSize: word;',
- ' function GetSpeed: word;',
- ' procedure SetSpeed(Value: word);',
- ' end;',
- ' TObjHelper = class helper for TObject',
- ' function GetLeft: word;',
- ' procedure SetLeft(Value: word);',
- ' property Size: word read FSize write FSize;',
- ' property Speed: word read GetSpeed write SetSpeed;',
- ' property Left: word read GetLeft write SetLeft;',
- ' end;',
- ' TBird = class',
- ' property NotRight: word read GetLeft write SetLeft;',
- ' procedure DoIt;',
- ' end;',
- 'var',
- ' b: TBird;',
- 'function Tobject.GetSpeed: word;',
- 'begin',
- ' Size:=Size+11;',
- ' Speed:=Speed+12;',
- ' Result:=Left+13;',
- ' Left:=13;',
- ' Left:=Left+13;',
- ' Self.Size:=Self.Size+21;',
- ' Self.Speed:=Self.Speed+22;',
- ' Self.Left:=Self.Left+23;',
- ' with Self do begin',
- ' Size:=Size+31;',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' end;',
- 'end;',
- 'procedure Tobject.SetSpeed(Value: word);',
- 'begin',
- 'end;',
- 'function TObjHelper.GetLeft: word;',
- 'begin',
- ' Size:=Size+11;',
- ' Speed:=Speed+12;',
- ' Left:=Left+13;',
- ' Self.Size:=Self.Size+21;',
- ' Self.Speed:=Self.Speed+22;',
- ' Self.Left:=Self.Left+23;',
- ' with Self do begin',
- ' Size:=Size+31;',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' end;',
- 'end;',
- 'procedure TObjHelper.SetLeft(Value: word);',
- 'begin',
- 'end;',
- 'procedure TBird.DoIt;',
- 'begin',
- ' NotRight:=NotRight+11;',
- ' Self.NotRight:=Self.NotRight+21;',
- ' with Self do begin',
- ' NotRight:=NotRight+31;',
- ' end;',
- 'end;',
- 'begin',
- ' b.Size:=b.Size+11;',
- ' b.Speed:=b.Speed+12;',
- ' b.Left:=b.Left+13;',
- ' b.NotRight:=b.NotRight+14;',
- ' with b do begin',
- ' Size:=Size+31;',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' NotRight:=NotRight+34;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_Property',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FSize = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetSpeed = function () {',
- ' var Result = 0;',
- ' this.FSize = this.FSize + 11;',
- ' this.SetSpeed(this.GetSpeed() + 12);',
- ' Result = $mod.TObjHelper.GetLeft.call(this) + 13;',
- ' $mod.TObjHelper.SetLeft.call(this, 13);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 13);',
- ' this.FSize = this.FSize + 21;',
- ' this.SetSpeed(this.GetSpeed() + 22);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 23);',
- ' this.FSize = this.FSize + 31;',
- ' this.SetSpeed(this.GetSpeed() + 32);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 33);',
- ' return Result;',
- ' };',
- ' this.SetSpeed = function (Value) {',
- ' };',
- '});',
- 'rtl.createHelper(this, "TObjHelper", null, function () {',
- ' this.GetLeft = function () {',
- ' var Result = 0;',
- ' this.FSize = this.FSize + 11;',
- ' this.SetSpeed(this.GetSpeed() + 12);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 13);',
- ' this.FSize = this.FSize + 21;',
- ' this.SetSpeed(this.GetSpeed() + 22);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 23);',
- ' this.FSize = this.FSize + 31;',
- ' this.SetSpeed(this.GetSpeed() + 32);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 33);',
- ' return Result;',
- ' };',
- ' this.SetLeft = function (Value) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 11);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 21);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 31);',
- ' };',
- '});',
- 'this.b = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.b.FSize = $mod.b.FSize + 11;',
- '$mod.b.SetSpeed($mod.b.GetSpeed() + 12);',
- '$mod.TObjHelper.SetLeft.call($mod.b, $mod.TObjHelper.GetLeft.call($mod.b) + 13);',
- '$mod.TObjHelper.SetLeft.call($mod.b, $mod.TObjHelper.GetLeft.call($mod.b) + 14);',
- 'var $with = $mod.b;',
- '$with.FSize = $with.FSize + 31;',
- '$with.SetSpeed($with.GetSpeed() + 32);',
- '$mod.TObjHelper.SetLeft.call($with, $mod.TObjHelper.GetLeft.call($with) + 33);',
- '$mod.TObjHelper.SetLeft.call($with, $mod.TObjHelper.GetLeft.call($with) + 34);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_Property_Array;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' function GetSpeed(Index: boolean): word;',
- ' procedure SetSpeed(Index: boolean; Value: word);',
- ' end;',
- ' TObjHelper = class helper for TObject',
- ' function GetSize(Index: boolean): word;',
- ' procedure SetSize(Index: boolean; Value: word);',
- ' property Size[Index: boolean]: word read GetSize write SetSize;',
- ' property Speed[Index: boolean]: word read GetSpeed write SetSpeed;',
- ' end;',
- ' TBird = class',
- ' property Items[Index: boolean]: word read GetSize write SetSize;',
- ' procedure DoIt;',
- ' end;',
- 'var',
- ' b: TBird;',
- 'function Tobject.GetSpeed(Index: boolean): word;',
- 'begin',
- ' Result:=Size[false];',
- ' Size[true]:=Size[false]+11;',
- ' Speed[true]:=Speed[false]+12;',
- ' Self.Size[true]:=Self.Size[false]+21;',
- ' Self.Speed[true]:=Self.Speed[false]+22;',
- ' with Self do begin',
- ' Size[true]:=Size[false]+31;',
- ' Speed[true]:=Speed[false]+32;',
- ' end;',
- 'end;',
- 'procedure Tobject.SetSpeed(Index: boolean; Value: word);',
- 'begin',
- 'end;',
- 'function TObjHelper.GetSize(Index: boolean): word;',
- 'begin',
- ' Size[true]:=Size[false]+11;',
- ' Speed[true]:=Speed[false]+12;',
- ' Self.Size[true]:=Self.Size[false]+21;',
- ' Self.Speed[true]:=Self.Speed[false]+22;',
- ' with Self do begin',
- ' Size[true]:=Size[false]+31;',
- ' Speed[true]:=Speed[false]+32;',
- ' end;',
- 'end;',
- 'procedure TObjHelper.SetSize(Index: boolean; Value: word);',
- 'begin',
- 'end;',
- 'procedure TBird.DoIt;',
- 'begin',
- ' Items[true]:=Items[false]+11;',
- ' Self.Items[true]:=Self.Items[false]+21;',
- ' with Self do Items[true]:=Items[false]+31;',
- 'end;',
- 'begin',
- ' b.Size[true]:=b.Size[false]+11;',
- ' b.Speed[true]:=b.Speed[false]+12;',
- ' b.Items[true]:=b.Items[false]+13;',
- ' with b do begin',
- ' Size[true]:=Size[false]+21;',
- ' Speed[true]:=Speed[false]+22;',
- ' Items[true]:=Items[false]+23;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_Property_Array',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetSpeed = function (Index) {',
- ' var Result = 0;',
- ' Result = $mod.TObjHelper.GetSize.call(this, false);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 11);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 12);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 21);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 22);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 31);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 32);',
- ' return Result;',
- ' };',
- ' this.SetSpeed = function (Index, Value) {',
- ' };',
- '});',
- 'rtl.createHelper(this, "TObjHelper", null, function () {',
- ' this.GetSize = function (Index) {',
- ' var Result = 0;',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 11);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 12);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 21);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 22);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 31);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 32);',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Index, Value) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 11);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 21);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 31);',
- ' };',
- '});',
- 'this.b = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TObjHelper.SetSize.call($mod.b, true, $mod.TObjHelper.GetSize.call($mod.b, false) + 11);',
- '$mod.b.SetSpeed(true, $mod.b.GetSpeed(false) + 12);',
- '$mod.TObjHelper.SetSize.call($mod.b, true, $mod.TObjHelper.GetSize.call($mod.b, false) + 13);',
- 'var $with = $mod.b;',
- '$mod.TObjHelper.SetSize.call($with, true, $mod.TObjHelper.GetSize.call($with, false) + 21);',
- '$with.SetSpeed(true, $with.GetSpeed(false) + 22);',
- '$mod.TObjHelper.SetSize.call($with, true, $mod.TObjHelper.GetSize.call($with, false) + 23);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_Property_Array_Default;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' function GetSpeed(Index: boolean): word;',
- ' procedure SetSpeed(Index: boolean; Value: word);',
- ' end;',
- ' TObjHelper = class helper for TObject',
- ' property Speed[Index: boolean]: word read GetSpeed write SetSpeed; default;',
- ' end;',
- ' TBird = class',
- ' end;',
- ' TBirdHelper = class helper for TBird',
- ' function GetSize(Index: word): boolean;',
- ' procedure SetSize(Index: word; Value: boolean);',
- ' property Size[Index: word]: boolean read GetSize write SetSize; default;',
- ' end;',
- 'function Tobject.GetSpeed(Index: boolean): word;',
- 'begin',
- ' Self[true]:=Self[false]+1;',
- 'end;',
- 'procedure Tobject.SetSpeed(Index: boolean; Value: word);',
- 'begin',
- 'end;',
- 'function TBirdHelper.GetSize(Index: word): boolean;',
- 'begin',
- ' Self[1]:=not Self[2];',
- 'end;',
- 'procedure TBirdHelper.SetSize(Index: word; Value: boolean);',
- 'begin',
- 'end;',
- 'var',
- ' o: TObject;',
- ' b: TBird;',
- 'begin',
- ' o[true]:=o[false]+1;',
- ' b[3]:=not b[4];',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_Property_Array_Default',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetSpeed = function (Index) {',
- ' var Result = 0;',
- ' this.SetSpeed(true, this.GetSpeed(false) + 1);',
- ' return Result;',
- ' };',
- ' this.SetSpeed = function (Index, Value) {',
- ' };',
- '});',
- 'rtl.createHelper(this, "TObjHelper", null, function () {',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- '});',
- 'rtl.createHelper(this, "TBirdHelper", null, function () {',
- ' this.GetSize = function (Index) {',
- ' var Result = false;',
- ' $mod.TBirdHelper.SetSize.call(this, 1, !$mod.TBirdHelper.GetSize.call(this, 2));',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Index, Value) {',
- ' };',
- '});',
- 'this.o = null;',
- 'this.b = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.o.SetSpeed(true, $mod.o.GetSpeed(false) + 1);',
- '$mod.TBirdHelper.SetSize.call($mod.b, 3, !$mod.TBirdHelper.GetSize.call($mod.b, 4));',
- '']));
- end;
- procedure TTestModule.TestClassHelper_Property_Array_DefaultDefault;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' end;',
- ' TObjHelper = class helper for TObject',
- ' function GetItems(Index: word): TObject;',
- ' procedure SetItems(Index: word; Value: TObject);',
- ' property Items[Index: word]: TObject read GetItems write SetItems; default;',
- ' end;',
- 'function Tobjhelper.GetItems(Index: word): TObject;',
- 'begin',
- ' Self[1][2]:=Self[3][4];',
- 'end;',
- 'procedure Tobjhelper.SetItems(Index: word; Value: TObject);',
- 'begin',
- 'end;',
- 'var',
- ' o: TObject;',
- 'begin',
- ' o[1][2]:=o[3][4];',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_Property_Array_DefaultDefault',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createHelper(this, "TObjHelper", null, function () {',
- ' this.GetItems = function (Index) {',
- ' var Result = null;',
- ' $mod.TObjHelper.SetItems.call($mod.TObjHelper.GetItems.call(this, 1), 2, $mod.TObjHelper.GetItems.call($mod.TObjHelper.GetItems.call(this, 3), 4));',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TObjHelper.SetItems.call($mod.TObjHelper.GetItems.call($mod.o, 1), 2, $mod.TObjHelper.GetItems.call($mod.TObjHelper.GetItems.call($mod.o, 3), 4));',
- '']));
- end;
- procedure TTestModule.TestClassHelper_ClassProperty;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' class var FSize: word;',
- ' class function GetSpeed: word;',
- ' class procedure SetSpeed(Value: word); virtual; abstract;',
- ' end;',
- ' TObjHelper = class helper for TObject',
- ' class function GetLeft: word;',
- ' class procedure SetLeft(Value: word);',
- ' class property Size: word read FSize write FSize;',
- ' class property Speed: word read GetSpeed write SetSpeed;',
- ' class property Left: word read GetLeft write SetLeft;',
- ' end;',
- ' TBird = class',
- ' class property NotRight: word read GetLeft write SetLeft;',
- ' class procedure DoIt;',
- ' end;',
- ' TBirdClass = class of TBird;',
- 'class function Tobject.GetSpeed: word;',
- 'begin',
- ' Size:=Size+11;',
- ' Speed:=Speed+12;',
- ' Left:=Left+13;',
- ' Self.Size:=Self.Size+21;',
- ' Self.Speed:=Self.Speed+22;',
- ' Self.Left:=Self.Left+23;',
- ' with Self do begin',
- ' Size:=Size+31;',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' end;',
- 'end;',
- 'class function TObjHelper.GetLeft: word;',
- 'begin',
- ' Size:=Size+11;',
- ' Speed:=Speed+12;',
- ' Left:=Left+13;',
- ' Self.Size:=Self.Size+21;',
- ' Self.Speed:=Self.Speed+22;',
- ' Self.Left:=Self.Left+23;',
- ' with Self do begin',
- ' Size:=Size+31;',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' end;',
- 'end;',
- 'class procedure TObjHelper.SetLeft(Value: word);',
- 'begin',
- 'end;',
- 'class procedure TBird.DoIt;',
- 'begin',
- ' NotRight:=NotRight+11;',
- ' Self.NotRight:=Self.NotRight+21;',
- ' with Self do NotRight:=NotRight+31;',
- 'end;',
- 'var',
- ' b: TBird;',
- ' c: TBirdClass;',
- 'begin',
- ' b.Size:=b.Size+11;',
- ' b.Speed:=b.Speed+12;',
- ' b.Left:=b.Left+13;',
- ' b.NotRight:=b.NotRight+14;',
- ' with b do begin',
- ' Size:=Size+31;',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' NotRight:=NotRight+34;',
- ' end;',
- ' c.Size:=c.Size+11;',
- ' c.Speed:=c.Speed+12;',
- ' c.Left:=c.Left+13;',
- ' c.NotRight:=c.NotRight+14;',
- ' with c do begin',
- ' Size:=Size+31;',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' NotRight:=NotRight+34;',
- ' end;',
- ' tbird.Size:=tbird.Size+11;',
- ' tbird.Speed:=tbird.Speed+12;',
- ' tbird.Left:=tbird.Left+13;',
- ' tbird.NotRight:=tbird.NotRight+14;',
- ' with tbird do begin',
- ' Size:=Size+31;',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' NotRight:=NotRight+34;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_ClassProperty',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.FSize = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetSpeed = function () {',
- ' var Result = 0;',
- ' $mod.TObject.FSize = this.FSize + 11;',
- ' this.SetSpeed(this.GetSpeed() + 12);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 13);',
- ' $mod.TObject.FSize = this.FSize + 21;',
- ' this.SetSpeed(this.GetSpeed() + 22);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 23);',
- ' $mod.TObject.FSize = this.FSize + 31;',
- ' this.SetSpeed(this.GetSpeed() + 32);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 33);',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createHelper(this, "TObjHelper", null, function () {',
- ' this.GetLeft = function () {',
- ' var Result = 0;',
- ' $mod.TObject.FSize = this.FSize + 11;',
- ' this.SetSpeed(this.GetSpeed() + 12);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 13);',
- ' $mod.TObject.FSize = this.FSize + 21;',
- ' this.SetSpeed(this.GetSpeed() + 22);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 23);',
- ' $mod.TObject.FSize = this.FSize + 31;',
- ' this.SetSpeed(this.GetSpeed() + 32);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 33);',
- ' return Result;',
- ' };',
- ' this.SetLeft = function (Value) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 11);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 21);',
- ' $mod.TObjHelper.SetLeft.call(this, $mod.TObjHelper.GetLeft.call(this) + 31);',
- ' };',
- '});',
- 'this.b = null;',
- 'this.c = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TObject.FSize = $mod.b.FSize + 11;',
- '$mod.b.$class.SetSpeed($mod.b.$class.GetSpeed() + 12);',
- '$mod.TObjHelper.SetLeft.call($mod.b.$class, $mod.TObjHelper.GetLeft.call($mod.b.$class) + 13);',
- '$mod.TObjHelper.SetLeft.call($mod.b.$class, $mod.TObjHelper.GetLeft.call($mod.b.$class) + 14);',
- 'var $with = $mod.b;',
- '$mod.TObject.FSize = $with.FSize + 31;',
- '$with.$class.SetSpeed($with.$class.GetSpeed() + 32);',
- '$mod.TObjHelper.SetLeft.call($with.$class, $mod.TObjHelper.GetLeft.call($with.$class) + 33);',
- '$mod.TObjHelper.SetLeft.call($with.$class, $mod.TObjHelper.GetLeft.call($with.$class) + 34);',
- '$mod.TObject.FSize = $mod.c.FSize + 11;',
- '$mod.c.SetSpeed($mod.c.GetSpeed() + 12);',
- '$mod.TObjHelper.SetLeft.call($mod.c, $mod.TObjHelper.GetLeft.call($mod.c) + 13);',
- '$mod.TObjHelper.SetLeft.call($mod.c, $mod.TObjHelper.GetLeft.call($mod.c) + 14);',
- 'var $with1 = $mod.c;',
- '$mod.TObject.FSize = $with1.FSize + 31;',
- '$with1.SetSpeed($with1.GetSpeed() + 32);',
- '$mod.TObjHelper.SetLeft.call($with1, $mod.TObjHelper.GetLeft.call($with1) + 33);',
- '$mod.TObjHelper.SetLeft.call($with1, $mod.TObjHelper.GetLeft.call($with1) + 34);',
- '$mod.TObject.FSize = $mod.TBird.FSize + 11;',
- '$mod.TBird.SetSpeed($mod.TBird.GetSpeed() + 12);',
- '$mod.TObjHelper.SetLeft.call($mod.TBird, $mod.TObjHelper.GetLeft.call($mod.TBird) + 13);',
- '$mod.TObjHelper.SetLeft.call($mod.TBird, $mod.TObjHelper.GetLeft.call($mod.TBird) + 14);',
- 'var $with2 = $mod.TBird;',
- '$mod.TObject.FSize = $with2.FSize + 31;',
- '$with2.SetSpeed($with2.GetSpeed() + 32);',
- '$mod.TObjHelper.SetLeft.call($mod.TBird, $mod.TObjHelper.GetLeft.call($mod.TBird) + 33);',
- '$mod.TObjHelper.SetLeft.call($mod.TBird, $mod.TObjHelper.GetLeft.call($mod.TBird) + 34);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_ClassPropertyStatic;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' class function GetSpeed: word; static;',
- ' class procedure SetSpeed(Value: word); static;',
- ' end;',
- ' TObjHelper = class helper for TObject',
- ' class function GetLeft: word; static;',
- ' class procedure SetLeft(Value: word); static;',
- ' class property Speed: word read GetSpeed write SetSpeed;',
- ' class property Left: word read GetLeft write SetLeft;',
- ' end;',
- ' TBird = class',
- ' class property NotRight: word read GetLeft write SetLeft;',
- ' class procedure DoIt; static;',
- ' class procedure DoSome;',
- ' end;',
- ' TBirdClass = class of TBird;',
- 'class function Tobject.GetSpeed: word;',
- 'begin',
- ' Speed:=Speed+12;',
- ' Left:=Left+13;',
- 'end;',
- 'class procedure TObject.SetSpeed(Value: word);',
- 'begin',
- 'end;',
- 'class function TObjHelper.GetLeft: word;',
- 'begin',
- ' Speed:=Speed+12;',
- ' Left:=Left+13;',
- 'end;',
- 'class procedure TObjHelper.SetLeft(Value: word);',
- 'begin',
- 'end;',
- 'class procedure TBird.DoIt;',
- 'begin',
- ' NotRight:=NotRight+11;',
- 'end;',
- 'class procedure TBird.DoSome;',
- 'begin',
- ' Speed:=Speed+12;',
- ' Left:=Left+13;',
- ' Self.Speed:=Self.Speed+22;',
- ' Self.Left:=Self.Left+23;',
- ' with Self do begin',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' end;',
- ' NotRight:=NotRight+11;',
- ' Self.NotRight:=Self.NotRight+21;',
- ' with Self do NotRight:=NotRight+31;',
- 'end;',
- 'var',
- ' b: TBird;',
- ' c: TBirdClass;',
- 'begin',
- ' b.Speed:=b.Speed+12;',
- ' b.Left:=b.Left+13;',
- ' b.NotRight:=b.NotRight+14;',
- ' with b do begin',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' NotRight:=NotRight+34;',
- ' end;',
- ' c.Speed:=c.Speed+12;',
- ' c.Left:=c.Left+13;',
- ' c.NotRight:=c.NotRight+14;',
- ' with c do begin',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' NotRight:=NotRight+34;',
- ' end;',
- ' tbird.Speed:=tbird.Speed+12;',
- ' tbird.Left:=tbird.Left+13;',
- ' tbird.NotRight:=tbird.NotRight+14;',
- ' with tbird do begin',
- ' Speed:=Speed+32;',
- ' Left:=Left+33;',
- ' NotRight:=NotRight+34;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_ClassPropertyStatic',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetSpeed = function () {',
- ' var Result = 0;',
- ' $mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
- ' return Result;',
- ' };',
- ' this.SetSpeed = function (Value) {',
- ' };',
- '});',
- 'rtl.createHelper(this, "TObjHelper", null, function () {',
- ' this.GetLeft = function () {',
- ' var Result = 0;',
- ' $mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
- ' return Result;',
- ' };',
- ' this.SetLeft = function (Value) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 11);',
- ' };',
- ' this.DoSome = function () {',
- ' this.SetSpeed(this.GetSpeed() + 12);',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
- ' this.SetSpeed(this.GetSpeed() + 22);',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 23);',
- ' this.SetSpeed(this.GetSpeed() + 32);',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 33);',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 11);',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 21);',
- ' $mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 31);',
- ' };',
- '});',
- 'this.b = null;',
- 'this.c = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 14);',
- 'var $with = $mod.b;',
- '$with.SetSpeed($with.GetSpeed() + 32);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 33);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 34);',
- '$mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 14);',
- 'var $with1 = $mod.c;',
- '$with1.SetSpeed($with1.GetSpeed() + 32);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 33);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 34);',
- '$mod.TObject.SetSpeed($mod.TObject.GetSpeed() + 12);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 13);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 14);',
- 'var $with2 = $mod.TBird;',
- '$with2.SetSpeed($with2.GetSpeed() + 32);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 33);',
- '$mod.TObjHelper.SetLeft($mod.TObjHelper.GetLeft() + 34);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_ClassProperty_Array;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' class function GetSpeed(Index: boolean): word;',
- ' class procedure SetSpeed(Index: boolean; Value: word); virtual; abstract;',
- ' end;',
- ' TObjHelper = class helper for TObject',
- ' class function GetSize(Index: boolean): word;',
- ' class procedure SetSize(Index: boolean; Value: word);',
- ' class property Size[Index: boolean]: word read GetSize write SetSize;',
- ' class property Speed[Index: boolean]: word read GetSpeed write SetSpeed;',
- ' end;',
- ' TBird = class',
- ' class property Items[Index: boolean]: word read GetSize write SetSize;',
- ' class procedure DoIt;',
- ' end;',
- ' TBirdClass = class of TBird;',
- 'class function Tobject.GetSpeed(Index: boolean): word;',
- 'begin',
- ' Size[true]:=Size[false]+11;',
- ' Speed[true]:=Speed[false]+12;',
- ' Self.Size[true]:=Self.Size[false]+21;',
- ' Self.Speed[true]:=Self.Speed[false]+22;',
- ' with Self do begin',
- ' Size[true]:=Size[false]+31;',
- ' Speed[true]:=Speed[false]+32;',
- ' end;',
- 'end;',
- 'class function TObjHelper.GetSize(Index: boolean): word;',
- 'begin',
- ' Size[true]:=Size[false]+11;',
- ' Speed[true]:=Speed[false]+12;',
- ' Self.Size[true]:=Self.Size[false]+21;',
- ' Self.Speed[true]:=Self.Speed[false]+22;',
- ' with Self do begin',
- ' Size[true]:=Size[false]+31;',
- ' Speed[true]:=Speed[false]+32;',
- ' end;',
- 'end;',
- 'class procedure TObjHelper.SetSize(Index: boolean; Value: word);',
- 'begin',
- 'end;',
- 'class procedure TBird.DoIt;',
- 'begin',
- ' Items[true]:=Items[false]+11;',
- ' Self.Items[true]:=Self.Items[false]+21;',
- ' with Self do Items[true]:=Items[false]+31;',
- 'end;',
- 'var',
- ' b: TBird;',
- ' c: TBirdClass;',
- 'begin',
- ' b.Size[true]:=b.Size[false]+11;',
- ' b.Speed[true]:=b.Speed[false]+12;',
- ' b.Items[true]:=b.Items[false]+13;',
- ' with b do begin',
- ' Size[true]:=Size[false]+21;',
- ' Speed[true]:=Speed[false]+22;',
- ' Items[true]:=Items[false]+23;',
- ' end;',
- ' c.Size[true]:=c.Size[false]+11;',
- ' c.Speed[true]:=c.Speed[false]+12;',
- ' c.Items[true]:=c.Items[false]+13;',
- ' with c do begin',
- ' Size[true]:=Size[false]+21;',
- ' Speed[true]:=Speed[false]+22;',
- ' Items[true]:=Items[false]+23;',
- ' end;',
- ' TBird.Size[true]:=TBird.Size[false]+11;',
- ' TBird.Speed[true]:=TBird.Speed[false]+12;',
- ' TBird.Items[true]:=TBird.Items[false]+13;',
- ' with TBird do begin',
- ' Size[true]:=Size[false]+21;',
- ' Speed[true]:=Speed[false]+22;',
- ' Items[true]:=Items[false]+23;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_ClassProperty_Array',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetSpeed = function (Index) {',
- ' var Result = 0;',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 11);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 12);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 21);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 22);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 31);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 32);',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createHelper(this, "TObjHelper", null, function () {',
- ' this.GetSize = function (Index) {',
- ' var Result = 0;',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 11);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 12);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 21);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 22);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 31);',
- ' this.SetSpeed(true, this.GetSpeed(false) + 32);',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Index, Value) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 11);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 21);',
- ' $mod.TObjHelper.SetSize.call(this, true, $mod.TObjHelper.GetSize.call(this, false) + 31);',
- ' };',
- '});',
- 'this.b = null;',
- 'this.c = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TObjHelper.SetSize.call($mod.b.$class, true, $mod.TObjHelper.GetSize.call($mod.b.$class, false) + 11);',
- '$mod.b.$class.SetSpeed(true, $mod.b.$class.GetSpeed(false) + 12);',
- '$mod.TObjHelper.SetSize.call($mod.b.$class, true, $mod.TObjHelper.GetSize.call($mod.b.$class, false) + 13);',
- 'var $with = $mod.b;',
- '$mod.TObjHelper.SetSize.call($with.$class, true, $mod.TObjHelper.GetSize.call($with.$class, false) + 21);',
- '$with.$class.SetSpeed(true, $with.$class.GetSpeed(false) + 22);',
- '$mod.TObjHelper.SetSize.call($with.$class, true, $mod.TObjHelper.GetSize.call($with.$class, false) + 23);',
- '$mod.TObjHelper.SetSize.call($mod.c, true, $mod.TObjHelper.GetSize.call($mod.c, false) + 11);',
- '$mod.c.SetSpeed(true, $mod.c.GetSpeed(false) + 12);',
- '$mod.TObjHelper.SetSize.call($mod.c, true, $mod.TObjHelper.GetSize.call($mod.c, false) + 13);',
- 'var $with1 = $mod.c;',
- '$mod.TObjHelper.SetSize.call($with1, true, $mod.TObjHelper.GetSize.call($with1, false) + 21);',
- '$with1.SetSpeed(true, $with1.GetSpeed(false) + 22);',
- '$mod.TObjHelper.SetSize.call($with1, true, $mod.TObjHelper.GetSize.call($with1, false) + 23);',
- '$mod.TObjHelper.SetSize.call($mod.TBird, true, $mod.TObjHelper.GetSize.call($mod.TBird, false) + 11);',
- '$mod.TBird.SetSpeed(true, $mod.TBird.GetSpeed(false) + 12);',
- '$mod.TObjHelper.SetSize.call($mod.TBird, true, $mod.TObjHelper.GetSize.call($mod.TBird, false) + 13);',
- 'var $with2 = $mod.TBird;',
- '$mod.TObjHelper.SetSize.call($mod.TBird, true, $mod.TObjHelper.GetSize.call($mod.TBird, false) + 21);',
- '$with2.SetSpeed(true, $with2.GetSpeed(false) + 22);',
- '$mod.TObjHelper.SetSize.call($mod.TBird, true, $mod.TObjHelper.GetSize.call($mod.TBird, false) + 23);',
- '']));
- end;
- procedure TTestModule.TestClassHelper_ForIn;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- ' TItem = TObject;',
- ' TEnumerator = class',
- ' FCurrent: TItem;',
- ' property Current: TItem read FCurrent;',
- ' function MoveNext: boolean;',
- ' end;',
- ' TBird = class',
- ' end;',
- ' TBirdHelper = class helper for TBird',
- ' function GetEnumerator: TEnumerator;',
- ' end;',
- 'function TEnumerator.MoveNext: boolean;',
- 'begin',
- 'end;',
- 'function TBirdHelper.GetEnumerator: TEnumerator;',
- 'begin',
- 'end;',
- 'var',
- ' b: TBird;',
- ' i, i2: TItem;',
- 'begin',
- ' for i in b do i2:=i;']);
- ConvertProgram;
- CheckSource('TestClassHelper_ForIn',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TEnumerator", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FCurrent = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FCurrent = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- ' this.MoveNext = function () {',
- ' var Result = false;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- '});',
- 'rtl.createHelper(this, "TBirdHelper", null, function () {',
- ' this.GetEnumerator = function () {',
- ' var Result = null;',
- ' return Result;',
- ' };',
- '});',
- 'this.b = null;',
- 'this.i = null;',
- 'this.i2 = null;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $in = $mod.TBirdHelper.GetEnumerator.call($mod.b);',
- 'try {',
- ' while ($in.MoveNext()){',
- ' $mod.i = $in.FCurrent;',
- ' $mod.i2 = $mod.i;',
- ' }',
- '} finally {',
- ' $in = rtl.freeLoc($in)',
- '};',
- '']));
- end;
- procedure TTestModule.TestClassHelper_PassProperty;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' FField: TObject;',
- ' property Field: TObject read FField write FField;',
- ' end;',
- ' THelper = class helper for TObject',
- ' procedure Fly;',
- ' class procedure Run;',
- ' class procedure Jump; static;',
- ' end;',
- 'procedure THelper.Fly;',
- 'begin',
- ' Field.Fly;',
- ' Field.Run;',
- ' Field.Jump;',
- ' with Field do begin',
- ' Fly;',
- ' Run;',
- ' Jump;',
- ' end;',
- 'end;',
- 'class procedure THelper.Run;',
- 'begin',
- 'end;',
- 'class procedure THelper.Jump;',
- 'begin',
- 'end;',
- 'var',
- ' b: TObject;',
- 'begin',
- ' b.Field.Fly;',
- ' b.Field.Run;',
- ' b.Field.Jump;',
- ' with b do begin',
- ' Field.Run;',
- ' Field.Fly;',
- ' Field.Jump;',
- ' end;',
- ' with b.Field do begin',
- ' Run;',
- ' Fly;',
- ' Jump;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClassHelper_PassProperty',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FField = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FField = undefined;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Fly = function () {',
- ' $mod.THelper.Fly.call(this.FField);',
- ' $mod.THelper.Run.call(this.FField.$class);',
- ' $mod.THelper.Jump();',
- ' var $with = this.FField;',
- ' $mod.THelper.Fly.call($with);',
- ' $mod.THelper.Run.call($with.$class);',
- ' $mod.THelper.Jump();',
- ' };',
- ' this.Run = function () {',
- ' };',
- ' this.Jump = function () {',
- ' };',
- '});',
- 'this.b = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Fly.call($mod.b.FField);',
- '$mod.THelper.Run.call($mod.b.FField.$class);',
- '$mod.THelper.Jump();',
- 'var $with = $mod.b;',
- '$mod.THelper.Run.call($with.FField.$class);',
- '$mod.THelper.Fly.call($with.FField);',
- '$mod.THelper.Jump();',
- 'var $with1 = $mod.b.FField;',
- '$mod.THelper.Run.call($with1.$class);',
- '$mod.THelper.Fly.call($with1);',
- '$mod.THelper.Jump();',
- '']));
- end;
- procedure TTestModule.TestExtClassHelper_ClassVar;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObj''',
- ' end;',
- ' THelper = class helper for TExtA',
- ' const',
- ' One = 1;',
- ' Two: word = 2;',
- ' class var',
- ' Glob: word;',
- ' function Foo(w: word): word;',
- ' class function Bar(w: word): word; static;',
- ' end;',
- 'function THelper.foo(w: word): word;',
- 'begin',
- ' Result:=w;',
- ' Two:=One+w;',
- ' Glob:=Glob;',
- ' Result:=Self.Glob;',
- ' Self.Glob:=Self.Glob;',
- ' with Self do Glob:=Glob;',
- 'end;',
- 'class function THelper.bar(w: word): word;',
- 'begin',
- ' Result:=w;',
- ' Two:=One;',
- ' Glob:=Glob;',
- 'end;',
- 'var o: TExtA;',
- 'begin',
- ' texta.two:=texta.one;',
- ' texta.Glob:=texta.Glob;',
- ' with texta do begin',
- ' two:=one;',
- ' Glob:=Glob;',
- ' end;',
- ' o.two:=o.one;',
- ' o.Glob:=o.Glob;',
- ' with o do begin',
- ' two:=one;',
- ' Glob:=Glob;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestExtClassHelper_ClassVar',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.One = 1;',
- ' this.Two = 2;',
- ' this.Glob = 0;',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' Result = w;',
- ' $mod.THelper.Two = 1 + w;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' Result = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' return Result;',
- ' };',
- ' this.Bar = function (w) {',
- ' var Result = 0;',
- ' Result = w;',
- ' $mod.THelper.Two = 1;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' return Result;',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- 'var $with = $mod.o;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '']));
- end;
- procedure TTestModule.TestExtClassHelper_Method_Call;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TFly = function(w: word): word of object;',
- ' TExtA = class external name ''ExtObj''',
- ' procedure Run(w: word = 10);',
- ' end;',
- ' THelper = class helper for TExtA',
- ' function Foo(w: word = 1): word;',
- ' function Fly(w: word = 2): word; external name ''Fly'';',
- ' end;',
- 'var p: TFly;',
- 'function THelper.foo(w: word): word;',
- 'begin',
- ' Run;',
- ' Run();',
- ' Run(11);',
- ' Foo;',
- ' Foo();',
- ' Foo(12);',
- ' Self.Foo;',
- ' Self.Foo();',
- ' Self.Foo(13);',
- ' Fly;',
- ' Fly();',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' Foo(14);',
- ' Fly;',
- ' Fly();',
- ' end;',
- ' p:=@Fly;',
- 'end;',
- 'var Obj: TExtA;',
- 'begin',
- ' obj.Foo;',
- ' obj.Foo();',
- ' obj.Foo(21);',
- ' obj.Fly;',
- ' obj.Fly();',
- ' with obj do begin',
- ' Foo;',
- ' Foo();',
- ' Foo(22);',
- ' Fly;',
- ' Fly();',
- ' end;',
- ' p:[email protected];',
- '']);
- ConvertProgram;
- CheckSource('TestExtClassHelper_Method_Call',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' this.Run(10);',
- ' this.Run(10);',
- ' this.Run(11);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 12);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 13);',
- ' this.Fly(2);',
- ' this.Fly(2);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 14);',
- ' this.Fly(2);',
- ' this.Fly(2);',
- ' $mod.p = rtl.createCallback(this, "Fly");',
- ' return Result;',
- ' };',
- '});',
- 'this.p = null;',
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Foo.call($mod.Obj, 1);',
- '$mod.THelper.Foo.call($mod.Obj, 1);',
- '$mod.THelper.Foo.call($mod.Obj, 21);',
- '$mod.Obj.Fly(2);',
- '$mod.Obj.Fly(2);',
- 'var $with = $mod.Obj;',
- '$mod.THelper.Foo.call($with, 1);',
- '$mod.THelper.Foo.call($with, 1);',
- '$mod.THelper.Foo.call($with, 22);',
- '$with.Fly(2);',
- '$with.Fly(2);',
- '$mod.p = rtl.createCallback($mod.Obj, "Fly");',
- '']));
- end;
- procedure TTestModule.TestExtClassHelper_ClassMethod_MissingStatic;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TExtA = class external name ''ExtObj''',
- ' procedure Run(w: word = 10);',
- ' end;',
- ' THelper = class helper for TExtA',
- ' class procedure Fly;',
- ' end;',
- 'class procedure THelper.Fly;',
- 'begin end;',
- 'begin',
- '']);
- SetExpectedPasResolverError(sHelperClassMethodForExtClassMustBeStatic,
- nHelperClassMethodForExtClassMustBeStatic);
- ConvertProgram;
- end;
- procedure TTestModule.TestRecordHelper_ClassVar;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TRec = record',
- ' end;',
- ' THelper = record helper for TRec',
- ' const',
- ' One = 1;',
- ' Two: word = 2;',
- ' class var',
- ' Glob: word;',
- ' function Foo(w: word): word;',
- ' class function Bar(w: word): word; static;',
- ' end;',
- 'function THelper.foo(w: word): word;',
- 'begin',
- ' Result:=w;',
- ' Two:=One+w;',
- ' Glob:=Glob;',
- ' Result:=Self.Glob;',
- ' Self.Glob:=Self.Glob;',
- ' with Self do Glob:=Glob;',
- ' Self:=Self;',
- 'end;',
- 'class function THelper.bar(w: word): word;',
- 'begin',
- ' Result:=w;',
- ' Two:=One;',
- ' Glob:=Glob;',
- 'end;',
- 'var r: TRec;',
- 'begin',
- ' trec.two:=trec.one;',
- ' trec.Glob:=trec.Glob;',
- ' with trec do begin',
- ' two:=one;',
- ' Glob:=Glob;',
- ' end;',
- ' r.two:=r.one;',
- ' r.Glob:=r.Glob;',
- ' with r do begin',
- ' two:=one;',
- ' Glob:=Glob;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestRecordHelper_ClassVar',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.One = 1;',
- ' this.Two = 2;',
- ' this.Glob = 0;',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' Result = w;',
- ' $mod.THelper.Two = 1 + w;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' Result = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' this.$assign(this);',
- ' return Result;',
- ' };',
- ' this.Bar = function (w) {',
- ' var Result = 0;',
- ' Result = w;',
- ' $mod.THelper.Two = 1;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' return Result;',
- ' };',
- '});',
- 'this.r = this.TRec.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- 'var $with = $mod.TRec;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- 'var $with1 = $mod.r;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '']));
- end;
- procedure TTestModule.TestRecordHelper_Method_Call;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TRec = record',
- ' procedure Run(w: word = 10);',
- ' end;',
- ' THelper = record helper for TRec',
- ' function Foo(w: word = 1): word;',
- ' end;',
- 'procedure TRec.Run(w: word);',
- 'begin',
- ' Foo;',
- ' Foo();',
- ' Foo(2);',
- ' Self.Foo;',
- ' Self.Foo();',
- ' Self.Foo(3);',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' Foo(4);',
- ' end;',
- 'end;',
- 'function THelper.foo(w: word): word;',
- 'begin',
- ' Run;',
- ' Run();',
- ' Run(11);',
- ' Foo;',
- ' Foo();',
- ' Foo(12);',
- ' Self.Foo;',
- ' Self.Foo();',
- ' Self.Foo(13);',
- ' with Self do begin',
- ' Foo;',
- ' Foo();',
- ' Foo(14);',
- ' end;',
- 'end;',
- 'var Rec: TRec;',
- 'begin',
- ' Rec.Foo;',
- ' Rec.Foo();',
- ' Rec.Foo(21);',
- ' with Rec do begin',
- ' Foo;',
- ' Foo();',
- ' Foo(22);',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestRecordHelper_Method_Call',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' this.Run = function (w) {',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 2);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 3);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 4);',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' this.Run(10);',
- ' this.Run(10);',
- ' this.Run(11);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 12);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 13);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 1);',
- ' $mod.THelper.Foo.call(this, 14);',
- ' return Result;',
- ' };',
- '});',
- 'this.Rec = this.TRec.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Foo.call($mod.Rec, 1);',
- '$mod.THelper.Foo.call($mod.Rec, 1);',
- '$mod.THelper.Foo.call($mod.Rec, 21);',
- 'var $with = $mod.Rec;',
- '$mod.THelper.Foo.call($with, 1);',
- '$mod.THelper.Foo.call($with, 1);',
- '$mod.THelper.Foo.call($with, 22);',
- '']));
- end;
- procedure TTestModule.TestRecordHelper_Constructor;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TRec = record',
- ' constructor Create(w: word);',
- ' end;',
- ' THelper = record helper for TRec',
- ' constructor NewHlp(w: word);',
- ' end;',
- 'var',
- ' Rec: TRec;',
- 'constructor TRec.Create(w: word);',
- 'begin',
- ' NewHlp(2);', // normal call
- ' trec.NewHlp(3);', // new instance
- 'end;',
- 'constructor THelper.NewHlp(w: word);',
- 'begin',
- ' create(2);', // normal call
- ' trec.create(3);', // new instance
- ' NewHlp(4);', // normal call
- ' trec.NewHlp(5);', // new instance
- 'end;',
- 'begin',
- ' rec.newhlp(2);', // normal call
- ' with rec do newhlp(12);', // normal call
- ' trec.newhlp(3);', // new instance
- ' with trec do newhlp(13);', // new instance
- '']);
- ConvertProgram;
- CheckSource('TestRecordHelper_Constructor',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' this.Create = function (w) {',
- ' $mod.THelper.NewHlp.call(this, 2);',
- ' $mod.THelper.$new("NewHlp", [3]);',
- ' return this;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.NewHlp = function (w) {',
- ' this.Create(2);',
- ' $mod.TRec.$new().Create(3);',
- ' $mod.THelper.NewHlp.call(this, 4);',
- ' $mod.THelper.$new("NewHlp", [5]);',
- ' return this;',
- ' };',
- ' this.$new = function (fn, args) {',
- ' return this[fn].apply($mod.TRec.$new(), args);',
- ' };',
- '});',
- 'this.Rec = this.TRec.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.NewHlp.call($mod.Rec, 2);',
- 'var $with = $mod.Rec;',
- '$mod.THelper.NewHlp.call($with, 12);',
- '$mod.THelper.$new("NewHlp", [3]);',
- 'var $with1 = $mod.TRec;',
- '$mod.THelper.$new("NewHlp", [13]);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_ClassVar;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for byte',
- ' const',
- ' One = 1;',
- ' Two: word = 2;',
- ' class var',
- ' Glob: word;',
- ' function Foo(w: word): word;',
- ' class function Bar(w: word): word; static;',
- ' end;',
- 'function THelper.foo(w: word): word;',
- 'begin',
- ' Result:=w;',
- ' Two:=One+w;',
- ' Glob:=Glob;',
- ' Result:=Self.Glob;',
- ' Self.Glob:=Self.Glob;',
- ' with Self do Glob:=Glob;',
- 'end;',
- 'class function THelper.bar(w: word): word;',
- 'begin',
- ' Result:=w;',
- ' Two:=One;',
- ' Glob:=Glob;',
- 'end;',
- 'var b: byte;',
- 'begin',
- ' byte.two:=byte.one;',
- ' byte.Glob:=byte.Glob;',
- ' with byte do begin',
- ' two:=one;',
- ' Glob:=Glob;',
- ' end;',
- ' b.two:=b.one;',
- ' b.Glob:=b.Glob;',
- ' with b do begin',
- ' two:=one;',
- ' Glob:=Glob;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_ClassVar',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.One = 1;',
- ' this.Two = 2;',
- ' this.Glob = 0;',
- ' this.Foo = function (w) {',
- ' var Result = 0;',
- ' Result = w;',
- ' $mod.THelper.Two = 1 + w;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' Result = $mod.THelper.Glob;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' var $with = this.get();',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' return Result;',
- ' };',
- ' this.Bar = function (w) {',
- ' var Result = 0;',
- ' Result = w;',
- ' $mod.THelper.Two = 1;',
- ' $mod.THelper.Glob = $mod.THelper.Glob;',
- ' return Result;',
- ' };',
- '});',
- 'this.b = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- 'var $with = $mod.b;',
- '$mod.THelper.Two = 1;',
- '$mod.THelper.Glob = $mod.THelper.Glob;',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassResultElement;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' procedure DoIt(e: byte = 123);',
- ' class procedure DoSome(e: byte = 456); static;',
- ' end;',
- 'procedure THelper.DoIt(e: byte);',
- 'begin',
- 'end;',
- 'class procedure THelper.DoSome(e: byte);',
- 'begin',
- 'end;',
- 'function Foo(w: word): word;',
- 'begin',
- ' Result.DoIt;',
- ' Result.DoIt();',
- ' Result.DoSome;',
- ' Result.DoSome();',
- ' with Result do begin',
- ' DoIt;',
- ' DoIt();',
- ' DoSome;',
- ' DoSome();',
- ' end;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassResultElement',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' };',
- ' this.DoSome = function (e) {',
- ' };',
- '});',
- 'this.Foo = function (w) {',
- ' var Result = 0;',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return Result;',
- ' },',
- ' set: function (v) {',
- ' Result = v;',
- ' }',
- ' }, 123);',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return Result;',
- ' },',
- ' set: function (v) {',
- ' Result = v;',
- ' }',
- ' }, 123);',
- ' $mod.THelper.DoSome(456);',
- ' $mod.THelper.DoSome(456);',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return Result;',
- ' },',
- ' set: function (v) {',
- ' Result = v;',
- ' }',
- ' }, 123);',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return Result;',
- ' },',
- ' set: function (v) {',
- ' Result = v;',
- ' }',
- ' }, 123);',
- ' $mod.THelper.DoSome(456);',
- ' $mod.THelper.DoSome(456);',
- ' return Result;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassArgs;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' procedure DoIt(e: byte = 123);',
- ' end;',
- 'procedure THelper.DoIt(e: byte);',
- 'begin',
- 'end;',
- 'procedure FooDefault(a: word);',
- 'begin',
- ' a.DoIt;',
- ' with a do DoIt;',
- 'end;',
- 'procedure FooConst(const a: word);',
- 'begin',
- ' a.DoIt;',
- ' with a do DoIt;',
- 'end;',
- 'procedure FooVar(var a: word);',
- 'begin',
- ' a.DoIt;',
- ' with a do DoIt;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassArgs',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' };',
- '});',
- 'this.FooDefault = function (a) {',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return a;',
- ' },',
- ' set: function (v) {',
- ' a = v;',
- ' }',
- ' }, 123);',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return a;',
- ' },',
- ' set: function (v) {',
- ' a = v;',
- ' }',
- ' }, 123);',
- '};',
- 'this.FooConst = function (a) {',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return a;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- ' }, 123);',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return a;',
- ' },',
- ' set: function () {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- ' }, 123);',
- '};',
- 'this.FooVar = function (a) {',
- ' $mod.THelper.DoIt.call(a, 123);',
- ' var $with = a.get();',
- ' $mod.THelper.DoIt.call(a, 123);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassVarConst;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' procedure DoIt(e: byte = 123);',
- ' end;',
- 'procedure THelper.DoIt(e: byte);',
- 'begin',
- 'end;',
- 'var a: word;',
- 'const c: word = 2;',
- '{$writeableconst off}',
- 'const r: word = 3;',
- 'begin',
- ' a.DoIt;',
- ' with a do DoIt;',
- ' c.DoIt;',
- ' with c do DoIt;',
- ' r.DoIt;',
- ' with r do DoIt;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassVarConst',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' };',
- '});',
- 'this.a = 0;',
- 'this.c = 2;',
- 'this.r = 3;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.DoIt.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.a;',
- ' },',
- ' set: function (v) {',
- ' this.p.a = v;',
- ' }',
- '}, 123);',
- 'var $with = $mod.a;',
- '$mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- '}, 123);',
- '$mod.THelper.DoIt.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.c;',
- ' },',
- ' set: function (v) {',
- ' this.p.c = v;',
- ' }',
- '}, 123);',
- 'var $with1 = $mod.c;',
- '$mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return $with1;',
- ' },',
- ' set: function (v) {',
- ' $with1 = v;',
- ' }',
- '}, 123);',
- '$mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return 3;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, 123);',
- 'var $with2 = 3;',
- ' $mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return $with2;',
- ' },',
- ' set: function () {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- ' }, 123);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassFuncResult;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' procedure DoIt(e: byte = 123);',
- ' end;',
- 'procedure THelper.DoIt(e: byte);',
- 'begin',
- 'end;',
- 'function Foo(b: byte = 1): word;',
- 'begin',
- 'end;',
- 'begin',
- ' Foo.DoIt;',
- ' Foo().DoIt;',
- ' with Foo do DoIt;',
- ' with Foo() do DoIt;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassFuncResult',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' };',
- '});',
- 'this.Foo = function (b) {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.DoIt.call({',
- ' a: $mod.Foo(1),',
- ' get: function () {',
- ' return this.a;',
- ' },',
- ' set: function (v) {',
- ' this.a = v;',
- ' }',
- '}, 123);',
- '$mod.THelper.DoIt.call({',
- ' a: $mod.Foo(1),',
- ' get: function () {',
- ' return this.a;',
- ' },',
- ' set: function (v) {',
- ' this.a = v;',
- ' }',
- '}, 123);',
- 'var $with = $mod.Foo(1);',
- '$mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- '}, 123);',
- 'var $with1 = $mod.Foo(1);',
- '$mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return $with1;',
- ' },',
- ' set: function (v) {',
- ' $with1 = v;',
- ' }',
- '}, 123);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassPropertyField;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TObject = class',
- ' FField: word;',
- ' procedure SetField(Value: word);',
- ' property Field: word read FField write SetField;',
- ' end;',
- ' THelper = type helper for word',
- ' procedure Fly;',
- ' class procedure Run; static;',
- ' end;',
- 'procedure TObject.SetField(Value: word);',
- 'begin',
- ' Field.Fly;',
- ' Field.Run;',
- ' Self.Field.Fly;',
- ' Self.Field.Run;',
- ' with Self do begin',
- ' Field.Fly;',
- ' Field.Run;',
- ' end;',
- ' with Self.Field do begin',
- ' Fly;',
- ' Run;',
- ' end;',
- 'end;',
- 'procedure THelper.Fly;',
- 'begin',
- 'end;',
- 'class procedure THelper.Run;',
- 'begin',
- 'end;',
- 'var',
- ' o: TObject;',
- 'begin',
- ' o.Field.Fly;',
- ' o.Field.Run;',
- ' with o do begin',
- ' Field.Fly;',
- ' Field.Run;',
- ' end;',
- ' with o.Field do begin',
- ' Fly;',
- ' Run;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassPropertyField',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FField = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.SetField = function (Value) {',
- ' $mod.THelper.Fly.call({',
- ' p: this,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' this.p.FField = v;',
- ' }',
- ' });',
- ' $mod.THelper.Run();',
- ' $mod.THelper.Fly.call({',
- ' p: this,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' this.p.FField = v;',
- ' }',
- ' });',
- ' $mod.THelper.Run();',
- ' $mod.THelper.Fly.call({',
- ' p: this,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' this.p.FField = v;',
- ' }',
- ' });',
- ' $mod.THelper.Run();',
- ' var $with = this.FField;',
- ' $mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- ' });',
- ' $mod.THelper.Run();',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Fly = function () {',
- ' };',
- ' this.Run = function () {',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Fly.call({',
- ' p: $mod.o,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' this.p.FField = v;',
- ' }',
- '});',
- '$mod.THelper.Run();',
- 'var $with = $mod.o;',
- '$mod.THelper.Fly.call({',
- ' p: $with,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' this.p.FField = v;',
- ' }',
- '});',
- '$mod.THelper.Run();',
- 'var $with1 = $mod.o.FField;',
- '$mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with1;',
- ' },',
- ' set: function (v) {',
- ' $with1 = v;',
- ' }',
- '});',
- '$mod.THelper.Run();',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassPropertyGetter;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TObject = class',
- ' FField: word;',
- ' function GetField: word;',
- ' property Field: word read GetField write FField;',
- ' end;',
- ' THelper = type helper for word',
- ' procedure Fly;',
- ' class procedure Run; static;',
- ' end;',
- 'function TObject.GetField: word;',
- 'begin',
- ' Field.Fly;',
- ' Field.Run;',
- ' Self.Field.Fly;',
- ' Self.Field.Run;',
- ' with Self do begin',
- ' Field.Fly;',
- ' Field.Run;',
- ' end;',
- ' with Self.Field do begin',
- ' Fly;',
- ' Run;',
- ' end;',
- 'end;',
- 'procedure THelper.Fly;',
- 'begin',
- 'end;',
- 'class procedure THelper.Run;',
- 'begin',
- 'end;',
- 'var',
- ' o: TObject;',
- 'begin',
- ' o.Field.Fly;',
- ' o.Field.Run;',
- ' with o do begin',
- ' Field.Fly;',
- ' Field.Run;',
- ' end;',
- ' with o.Field do begin',
- ' Fly;',
- ' Run;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassPropertyGetter',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FField = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetField = function () {',
- ' var Result = 0;',
- ' $mod.THelper.Fly.call({',
- ' p: this.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' });',
- ' $mod.THelper.Run();',
- ' $mod.THelper.Fly.call({',
- ' p: this.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' });',
- ' $mod.THelper.Run();',
- ' $mod.THelper.Fly.call({',
- ' p: this.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' });',
- ' $mod.THelper.Run();',
- ' var $with = this.GetField();',
- ' $mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- ' });',
- ' $mod.THelper.Run();',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Fly = function () {',
- ' };',
- ' this.Run = function () {',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Fly.call({',
- ' p: $mod.o.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- '});',
- '$mod.THelper.Run();',
- 'var $with = $mod.o;',
- '$mod.THelper.Fly.call({',
- ' p: $with.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- '});',
- '$mod.THelper.Run();',
- 'var $with1 = $mod.o.GetField();',
- '$mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with1;',
- ' },',
- ' set: function (v) {',
- ' $with1 = v;',
- ' }',
- '});',
- '$mod.THelper.Run();',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassClassPropertyField;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TObject = class',
- ' class var FField: word;',
- ' class procedure SetField(Value: word);',
- ' class property Field: word read FField write SetField;',
- ' end;',
- ' THelper = type helper for word',
- ' procedure Fly(n: byte);',
- ' end;',
- 'class procedure TObject.SetField(Value: word);',
- 'begin',
- ' Field.Fly(1);',
- ' Self.Field.Fly(2);',
- ' with Self do Field.Fly(3);',
- ' with Self.Field do Fly(4);',
- ' TObject.Field.Fly(5);',
- ' with TObject do Field.Fly(6);',
- ' with TObject.Field do Fly(7);',
- 'end;',
- 'procedure THelper.Fly(n: byte);',
- 'begin',
- 'end;',
- 'var',
- ' o: TObject;',
- 'begin',
- ' o.Field.Fly(11);',
- ' with o do Field.Fly(12);',
- ' with o.Field do Fly(13);',
- ' TObject.Field.Fly(14);',
- ' with TObject do Field.Fly(15);',
- ' with TObject.Field do Fly(16);',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassClassPropertyField',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.FField = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.SetField = function (Value) {',
- ' $mod.THelper.Fly.call({',
- ' p: this,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- ' }, 1);',
- ' $mod.THelper.Fly.call({',
- ' p: this,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- ' }, 2);',
- ' $mod.THelper.Fly.call({',
- ' p: this,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- ' }, 3);',
- ' var $with = this.FField;',
- ' $mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- ' }, 4);',
- ' $mod.THelper.Fly.call({',
- ' p: $mod.TObject,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- ' }, 5);',
- ' var $with1 = $mod.TObject;',
- ' $mod.THelper.Fly.call({',
- ' p: $with1,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- ' }, 6);',
- ' var $with2 = $mod.TObject.FField;',
- ' $mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with2;',
- ' },',
- ' set: function (v) {',
- ' $with2 = v;',
- ' }',
- ' }, 7);',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Fly = function (n) {',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Fly.call({',
- ' p: $mod.o,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- '}, 11);',
- 'var $with = $mod.o;',
- '$mod.THelper.Fly.call({',
- ' p: $with,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- '}, 12);',
- 'var $with1 = $mod.o.FField;',
- '$mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with1;',
- ' },',
- ' set: function (v) {',
- ' $with1 = v;',
- ' }',
- '}, 13);',
- '$mod.THelper.Fly.call({',
- ' p: $mod.TObject,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- '}, 14);',
- 'var $with2 = $mod.TObject;',
- '$mod.THelper.Fly.call({',
- ' p: $with2,',
- ' get: function () {',
- ' return this.p.FField;',
- ' },',
- ' set: function (v) {',
- ' $mod.TObject.FField = v;',
- ' }',
- '}, 15);',
- 'var $with3 = $mod.TObject.FField;',
- '$mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with3;',
- ' },',
- ' set: function (v) {',
- ' $with3 = v;',
- ' }',
- '}, 16);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassClassPropertyGetterStatic;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TObject = class',
- ' class var FField: word;',
- ' class function GetField: word; static;',
- ' class property Field: word read GetField write FField;',
- ' end;',
- ' THelper = type helper for word',
- ' procedure Fly(n: byte);',
- ' end;',
- 'class function TObject.GetField: word;',
- 'begin',
- ' Field.Fly(1);',
- ' TObject.Field.Fly(5);',
- ' with TObject do Field.Fly(6);',
- ' with TObject.Field do Fly(7);',
- 'end;',
- 'procedure THelper.Fly(n: byte);',
- 'begin',
- 'end;',
- 'var',
- ' o: TObject;',
- 'begin',
- ' o.Field.Fly(11);',
- ' with o do Field.Fly(12);',
- ' with o.Field do Fly(13);',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassClassPropertyGetterStatic',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.FField = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetField = function () {',
- ' var Result = 0;',
- ' $mod.THelper.Fly.call({',
- ' p: $mod.TObject.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' }, 1);',
- ' $mod.THelper.Fly.call({',
- ' p: $mod.TObject.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' }, 5);',
- ' var $with = $mod.TObject;',
- ' $mod.THelper.Fly.call({',
- ' p: $with.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' }, 6);',
- ' var $with1 = $mod.TObject.GetField();',
- ' $mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with1;',
- ' },',
- ' set: function (v) {',
- ' $with1 = v;',
- ' }',
- ' }, 7);',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Fly = function (n) {',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Fly.call({',
- ' p: $mod.TObject.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- '}, 11);',
- 'var $with = $mod.o;',
- '$mod.THelper.Fly.call({',
- ' p: $with.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- '}, 12);',
- 'var $with1 = $mod.TObject.GetField();',
- '$mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with1;',
- ' },',
- ' set: function (v) {',
- ' $with1 = v;',
- ' }',
- '}, 13);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_PassClassPropertyGetterNonStatic;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TObject = class',
- ' class var FField: word;',
- ' class function GetField: word;',
- ' class property Field: word read GetField write FField;',
- ' end;',
- ' TClass = class of TObject;',
- ' THelper = type helper for word',
- ' procedure Fly(n: byte);',
- ' end;',
- 'class function TObject.GetField: word;',
- 'begin',
- ' Field.Fly(1);',
- ' Self.Field.Fly(5);',
- ' with Self do Field.Fly(6);',
- ' with Self.Field do Fly(7);',
- 'end;',
- 'procedure THelper.Fly(n: byte);',
- 'begin',
- 'end;',
- 'var',
- ' o: TObject;',
- ' c: TClass;',
- 'begin',
- ' o.Field.Fly(11);',
- ' with o do Field.Fly(12);',
- ' with o.Field do Fly(13);',
- ' c.Field.Fly(14);',
- ' with c do Field.Fly(15);',
- ' with c.Field do Fly(16);',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_PassClassPropertyGetterNonStatic',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.FField = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetField = function () {',
- ' var Result = 0;',
- ' $mod.THelper.Fly.call({',
- ' p: this.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' }, 1);',
- ' $mod.THelper.Fly.call({',
- ' p: this.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' }, 5);',
- ' $mod.THelper.Fly.call({',
- ' p: this.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' }, 6);',
- ' var $with = this.GetField();',
- ' $mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- ' }, 7);',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Fly = function (n) {',
- ' };',
- '});',
- 'this.o = null;',
- 'this.c = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Fly.call({',
- ' p: $mod.o.$class.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- '}, 11);',
- 'var $with = $mod.o;',
- '$mod.THelper.Fly.call({',
- ' p: $with.$class.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- '}, 12);',
- 'var $with1 = $mod.o.$class.GetField();',
- '$mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with1;',
- ' },',
- ' set: function (v) {',
- ' $with1 = v;',
- ' }',
- '}, 13);',
- '$mod.THelper.Fly.call({',
- ' p: $mod.c.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- '}, 14);',
- 'var $with2 = $mod.c;',
- '$mod.THelper.Fly.call({',
- ' p: $with2.GetField(),',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- '}, 15);',
- 'var $with3 = $mod.c.GetField();',
- '$mod.THelper.Fly.call({',
- ' get: function () {',
- ' return $with3;',
- ' },',
- ' set: function (v) {',
- ' $with3 = v;',
- ' }',
- '}, 16);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_Property;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' function GetSize: longint;',
- ' procedure SetSize(Value: longint);',
- ' property Size: longint read GetSize write SetSize;',
- ' end;',
- 'function THelper.GetSize: longint;',
- 'begin',
- ' Result:=Size+1;',
- ' Size:=2;',
- ' Result:=Self.Size+3;',
- ' Self.Size:=4;',
- ' with Self do begin',
- ' Result:=Size+5;',
- ' Size:=6;',
- ' end;',
- 'end;',
- 'procedure THelper.SetSize(Value: longint);',
- 'begin',
- 'end;',
- 'var w: word;',
- 'begin',
- ' w:=w.Size+7;',
- ' w.Size:=w+8;',
- ' with w do begin',
- ' w:=Size+9;',
- ' Size:=w+10;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_Property',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.GetSize = function () {',
- ' var Result = 0;',
- ' Result = $mod.THelper.GetSize.call(this) + 1;',
- ' $mod.THelper.SetSize.call(this, 2);',
- ' Result = $mod.THelper.GetSize.call(this) + 3;',
- ' $mod.THelper.SetSize.call(this, 4);',
- ' var $with = this.get();',
- ' Result = $mod.THelper.GetSize.call(this) + 5;',
- ' $mod.THelper.SetSize.call(this, 6);',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Value) {',
- ' };',
- '});',
- 'this.w = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.w = $mod.THelper.GetSize.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.w;',
- ' },',
- ' set: function (v) {',
- ' this.p.w = v;',
- ' }',
- '}) + 7;',
- '$mod.THelper.SetSize.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.w;',
- ' },',
- ' set: function (v) {',
- ' this.p.w = v;',
- ' }',
- '}, $mod.w + 8);',
- 'var $with = $mod.w;',
- '$mod.w = $mod.THelper.GetSize.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- '}) + 9;',
- '$mod.THelper.SetSize.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- '}, $mod.w + 10);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_Property_Array;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' function GetItems(Index: byte): boolean;',
- ' procedure SetItems(Index: byte; Value: boolean);',
- ' property Items[Index: byte]: boolean read GetItems write SetItems;',
- ' end;',
- 'function THelper.GetItems(Index: byte): boolean;',
- 'begin',
- ' Result:=Items[1];',
- ' Items[2]:=false;',
- ' Result:=Self.Items[3];',
- ' Self.Items[4]:=true;',
- ' with Self do begin',
- ' Result:=Items[5];',
- ' Items[6]:=false;',
- ' end;',
- 'end;',
- 'procedure THelper.SetItems(Index: byte; Value: boolean);',
- 'begin',
- 'end;',
- 'var',
- ' w: word;',
- ' b: boolean;',
- 'begin',
- ' b:=w.Items[1];',
- ' w.Items[2]:=b;',
- ' with w do begin',
- ' b:=Items[3];',
- ' Items[4]:=b;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_Property_Array',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.GetItems = function (Index) {',
- ' var Result = false;',
- ' Result = $mod.THelper.GetItems.call(this, 1);',
- ' $mod.THelper.SetItems.call(this, 2, false);',
- ' Result = $mod.THelper.GetItems.call(this, 3);',
- ' $mod.THelper.SetItems.call(this, 4, true);',
- ' var $with = this.get();',
- ' Result = $mod.THelper.GetItems.call(this, 5);',
- ' $mod.THelper.SetItems.call(this, 6, false);',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' };',
- '});',
- 'this.w = 0;',
- 'this.b = false;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.b = $mod.THelper.GetItems.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.w;',
- ' },',
- ' set: function (v) {',
- ' this.p.w = v;',
- ' }',
- '}, 1);',
- '$mod.THelper.SetItems.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.w;',
- ' },',
- ' set: function (v) {',
- ' this.p.w = v;',
- ' }',
- '}, 2, $mod.b);',
- 'var $with = $mod.w;',
- '$mod.b = $mod.THelper.GetItems.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- '}, 3);',
- '$mod.THelper.SetItems.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- '}, 4, $mod.b);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_ClassProperty;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' class function GetSize: longint; static;',
- ' class procedure SetSize(Value: longint); static;',
- ' class property Size: longint read GetSize write SetSize;',
- ' end;',
- 'class function THelper.GetSize: longint;',
- 'begin',
- ' Result:=Size+1;',
- ' Size:=2;',
- 'end;',
- 'class procedure THelper.SetSize(Value: longint);',
- 'begin',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_ClassProperty',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.GetSize = function () {',
- ' var Result = 0;',
- ' Result = $mod.THelper.GetSize() + 1;',
- ' $mod.THelper.SetSize(2);',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Value) {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestTypeHelper_ClassProperty_Array;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' class function GetItems(Index: byte): boolean; static;',
- ' class procedure SetItems(Index: byte; Value: boolean); static;',
- ' class property Items[Index: byte]: boolean read GetItems write SetItems;',
- ' end;',
- 'class function THelper.GetItems(Index: byte): boolean;',
- 'begin',
- ' Result:=Items[1];',
- ' Items[2]:=false;',
- 'end;',
- 'class procedure THelper.SetItems(Index: byte; Value: boolean);',
- 'begin',
- 'end;',
- 'var',
- ' w: word;',
- ' b: boolean;',
- 'begin',
- ' b:=w.Items[1];',
- ' w.Items[2]:=b;',
- ' with w do begin',
- ' b:=Items[3];',
- ' Items[4]:=b;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_ClassProperty_Array',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.GetItems = function (Index) {',
- ' var Result = false;',
- ' Result = $mod.THelper.GetItems(1);',
- ' $mod.THelper.SetItems(2, false);',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' };',
- '});',
- 'this.w = 0;',
- 'this.b = false;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.b = $mod.THelper.GetItems(1);',
- '$mod.THelper.SetItems(2, $mod.b);',
- 'var $with = $mod.w;',
- '$mod.b = $mod.THelper.GetItems(3);',
- '$mod.THelper.SetItems(4, $mod.b);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_ClassMethod;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' class procedure DoStatic; static;',
- ' end;',
- 'class procedure THelper.DoStatic;',
- 'begin',
- ' DoStatic;',
- ' DoStatic();',
- 'end;',
- 'var w: word;',
- 'begin',
- ' w.DoStatic;',
- ' w.DoStatic();',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_ClassMethod',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoStatic = function () {',
- ' $mod.THelper.DoStatic();',
- ' $mod.THelper.DoStatic();',
- ' };',
- '});',
- 'this.w = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.DoStatic();',
- '$mod.THelper.DoStatic();',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_ExtClassMethodFail;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' procedure Run; external name ''Run'';',
- ' end;',
- 'var w: word;',
- 'begin',
- ' w.Run;',
- '']);
- SetExpectedPasResolverError('Not supported: external method in type helper',nNotSupportedX);
- ConvertProgram;
- end;
- procedure TTestModule.TestTypeHelper_Constructor;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' constructor Init(e: longint);',
- ' end;',
- 'constructor THelper.Init(e: longint);',
- 'begin',
- ' Self:=e;',
- ' Init(e+1);',
- 'end;',
- 'var w: word;',
- 'begin',
- ' w:=word.Init(2);',
- ' w:=w.Init(3);',
- ' with word do w:=Init(4);',
- ' with w do w:=Init(5);',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_Constructor',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Init = function (e) {',
- ' this.set(e);',
- ' $mod.THelper.Init.call(this, e + 1);',
- ' return this.get();',
- ' };',
- ' this.$new = function (fn, args) {',
- ' return this[fn].apply({',
- ' p: 0,',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' }, args);',
- ' };',
- '});',
- 'this.w = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.w = $mod.THelper.$new("Init", [2]);',
- '$mod.w = $mod.THelper.Init.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.w;',
- ' },',
- ' set: function (v) {',
- ' this.p.w = v;',
- ' }',
- '}, 3);',
- '$mod.w = $mod.THelper.$new("Init", [4]);',
- 'var $with = $mod.w;',
- '$mod.w = $mod.THelper.Init.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' $with = v;',
- ' }',
- '}, 5);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_Word;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for word',
- ' procedure DoIt(e: byte = 123);',
- ' end;',
- 'procedure THelper.DoIt(e: byte);',
- 'begin',
- ' Self:=e;',
- ' Self:=Self+1;',
- ' with Self do Doit;',
- 'end;',
- 'begin',
- ' word(3).DoIt;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_Word',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' this.set(e);',
- ' this.set(this.get() + 1);',
- ' var $with = this.get();',
- ' $mod.THelper.DoIt.call(this, 123);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return 3;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, 123);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_Boolean;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' Integer = longint;',
- ' THelper = type helper for boolean',
- ' procedure Run(e: wordbool = true);',
- ' end;',
- 'procedure THelper.Run(e: wordbool);',
- 'begin',
- ' Self:=e;',
- ' Self:=not Self;',
- ' with Self do Run;',
- ' if Integer(Self)=0 then ;',
- 'end;',
- 'begin',
- ' boolean(3).Run;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_Boolean',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Run = function (e) {',
- ' this.set(e);',
- ' this.set(!this.get());',
- ' var $with = this.get();',
- ' $mod.THelper.Run.call(this, true);',
- ' if ((this.get() ? 1 : 0) === 0) ;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Run.call({',
- ' a: 3 != 0,',
- ' get: function () {',
- ' return this.a;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, true);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_WordBool;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' Integer = longint;',
- ' THelper = type helper for WordBool',
- ' procedure Run(e: wordbool = true);',
- ' end;',
- 'procedure THelper.Run(e: wordbool);',
- 'var i: integer;',
- 'begin',
- ' i:=Integer(Self);',
- 'end;',
- 'var w: wordbool;',
- 'begin',
- ' w.Run;',
- ' wordbool(3).Run;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_WordBool',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Run = function (e) {',
- ' var i = 0;',
- ' i = (this.get() ? 1 : 0);',
- ' };',
- '});',
- 'this.w = false;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Run.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.w;',
- ' },',
- ' set: function (v) {',
- ' this.p.w = v;',
- ' }',
- '}, true);',
- '$mod.THelper.Run.call({',
- ' a: 3 != 0,',
- ' get: function () {',
- ' return this.a;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, true);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_Double;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' Float = type double;',
- ' THelper = type helper for Float',
- ' const NPI = 3.141592;',
- ' function ToStr: String;',
- ' end;',
- 'function THelper.ToStr: String;',
- 'begin',
- 'end;',
- 'procedure DoIt(s: string);',
- 'begin',
- 'end;',
- 'var f: Float;',
- 'begin',
- ' DoIt(f.toStr);',
- ' DoIt(f.toStr());',
- ' (f*f).toStr;',
- ' DoIt((f*f).toStr);',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_Double',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.NPI = 3.141592;',
- ' this.ToStr = function () {',
- ' var Result = "";',
- ' return Result;',
- ' };',
- '});',
- 'this.DoIt = function (s) {',
- '};',
- 'this.f = 0.0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.THelper.ToStr.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.f;',
- ' },',
- ' set: function (v) {',
- ' this.p.f = v;',
- ' }',
- '}));',
- '$mod.DoIt($mod.THelper.ToStr.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.f;',
- ' },',
- ' set: function (v) {',
- ' this.p.f = v;',
- ' }',
- '}));',
- '$mod.THelper.ToStr.call({',
- ' a: $mod.f * $mod.f,',
- ' get: function () {',
- ' return this.a;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '});',
- '$mod.DoIt($mod.THelper.ToStr.call({',
- ' a: $mod.f * $mod.f,',
- ' get: function () {',
- ' return this.a;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}));',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_NativeInt;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' MaxInt = type nativeint;',
- ' THelperI = type helper for MaxInt',
- ' function ToStr: String;',
- ' end;',
- ' MaxUInt = type nativeuint;',
- ' THelperU = type helper for MaxUInt',
- ' function ToStr: String;',
- ' end;',
- 'function THelperI.ToStr: String;',
- 'begin',
- ' Result:=str(Self);',
- 'end;',
- 'function THelperU.ToStr: String;',
- 'begin',
- ' Result:=str(Self);',
- 'end;',
- 'procedure DoIt(s: string);',
- 'begin',
- 'end;',
- 'var i: MaxInt;',
- 'begin',
- ' DoIt(i.toStr);',
- ' DoIt(i.toStr());',
- ' (i*i).toStr;',
- ' DoIt((i*i).toStr);',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_NativeInt',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelperI", null, function () {',
- ' this.ToStr = function () {',
- ' var Result = "";',
- ' Result = "" + this.get();',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelperU", null, function () {',
- ' this.ToStr = function () {',
- ' var Result = "";',
- ' Result = "" + this.get();',
- ' return Result;',
- ' };',
- '});',
- 'this.DoIt = function (s) {',
- '};',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.THelperI.ToStr.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '}));',
- '$mod.DoIt($mod.THelperI.ToStr.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '}));',
- '$mod.THelperI.ToStr.call({',
- ' a: $mod.i * $mod.i,',
- ' get: function () {',
- ' return this.a;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '});',
- '$mod.DoIt($mod.THelperI.ToStr.call({',
- ' a: $mod.i * $mod.i,',
- ' get: function () {',
- ' return this.a;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}));',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_StringChar;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TStringHelper = type helper for string',
- ' procedure DoIt(e: byte = 123);',
- ' end;',
- ' TCharHelper = type helper for char',
- ' procedure Fly;',
- ' end;',
- 'procedure TStringHelper.DoIt(e: byte);',
- 'begin',
- ' Self[1]:=''c'';',
- ' Self[2]:=Self[3];',
- 'end;',
- 'procedure TCharHelper.Fly;',
- 'begin',
- ' Self:=''c'';',
- 'end;',
- 'begin',
- ' ''abc''.DoIt;',
- ' ''xyz''.DoIt();',
- ' ''c''.Fly();',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_StringChar',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "TStringHelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' this.set(rtl.setCharAt(this.get(), 0, "c"));',
- ' this.set(rtl.setCharAt(this.get(), 1, this.get().charAt(2)));',
- ' };',
- '});',
- 'rtl.createHelper(this, "TCharHelper", null, function () {',
- ' this.Fly = function () {',
- ' this.set("c");',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TStringHelper.DoIt.call({',
- ' get: function () {',
- ' return "abc";',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, 123);',
- '$mod.TStringHelper.DoIt.call({',
- ' get: function () {',
- ' return "xyz";',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, 123);',
- '$mod.TCharHelper.Fly.call({',
- ' get: function () {',
- ' return "c";',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '});',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_JSValue;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TExtValue = type jsvalue;',
- ' THelper = type helper for TExtValue',
- ' function ToStr: String;',
- ' end;',
- 'function THelper.ToStr: String;',
- 'begin',
- 'end;',
- 'var',
- ' s: string;',
- ' v: TExtValue;',
- 'begin',
- ' s:=v.toStr;',
- ' s:=v.toStr();',
- ' TExtValue(s).toStr;',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_JSValue',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.ToStr = function () {',
- ' var Result = "";',
- ' return Result;',
- ' };',
- '});',
- 'this.s = "";',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.s = $mod.THelper.ToStr.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.v;',
- ' },',
- ' set: function (v) {',
- ' this.p.v = v;',
- ' }',
- '});',
- '$mod.s = $mod.THelper.ToStr.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.v;',
- ' },',
- ' set: function (v) {',
- ' this.p.v = v;',
- ' }',
- '});',
- '$mod.THelper.ToStr.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.s;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '});',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_Array;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TArrOfBool = array of boolean;',
- ' TArrOfJS = array of jsvalue;',
- ' THelper = type helper for TArrOfBool',
- ' procedure DoIt(e: byte = 123);',
- ' end;',
- 'procedure THelper.DoIt(e: byte);',
- 'begin',
- ' Self[1]:=true;',
- ' Self[2]:=not Self[3];',
- ' SetLength(Self,4);',
- 'end;',
- 'var',
- ' b: TArrOfBool;',
- ' j: TArrOfJS;',
- 'begin',
- ' b.DoIt;',
- ' TArrOfBool(j).DoIt();',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_Array',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' this.get()[1] = true;',
- ' this.get()[2] = !this.get()[3];',
- ' this.set(rtl.arraySetLength(this.get(), false, 4));',
- ' };',
- '});',
- 'this.b = [];',
- 'this.j = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.DoIt.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.b;',
- ' },',
- ' set: function (v) {',
- ' this.p.b = v;',
- ' }',
- '}, 123);',
- '$mod.THelper.DoIt.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.j;',
- ' },',
- ' set: function (v) {',
- ' this.p.j = v;',
- ' }',
- '}, 123);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_EnumType;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TEnum = (red,blue);',
- ' THelper = type helper for TEnum',
- ' procedure DoIt(e: byte = 123);',
- ' class procedure Swing(w: word); static;',
- ' end;',
- 'procedure THelper.DoIt(e: byte);',
- 'begin',
- ' Self:=red;',
- ' Self:=succ(Self);',
- ' with Self do Doit;',
- 'end;',
- 'class procedure THelper.Swing(w: word);',
- 'begin',
- 'end;',
- 'var e: TEnum;',
- 'begin',
- ' e.DoIt;',
- ' red.DoIt;',
- ' TEnum.blue.DoIt;',
- ' TEnum(1).DoIt;',
- ' TEnum.Swing(3);',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_EnumType',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' this.set($mod.TEnum.red);',
- ' this.set(this.get() + 1);',
- ' var $with = this.get();',
- ' $mod.THelper.DoIt.call(this, 123);',
- ' };',
- ' this.Swing = function (w) {',
- ' };',
- '});',
- 'this.e = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.DoIt.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.e;',
- ' },',
- ' set: function (v) {',
- ' this.p.e = v;',
- ' }',
- '}, 123);',
- '$mod.THelper.DoIt.call({',
- ' p: $mod.TEnum,',
- ' get: function () {',
- ' return this.p.red;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, 123);',
- '$mod.THelper.DoIt.call({',
- ' p: $mod.TEnum,',
- ' get: function () {',
- ' return this.p.blue;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, 123);',
- '$mod.THelper.DoIt.call({',
- ' get: function () {',
- ' return 1;',
- ' },',
- ' set: function (v) {',
- ' rtl.raiseE("EPropReadOnly");',
- ' }',
- '}, 123);',
- '$mod.THelper.Swing(3);',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_SetType;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' TEnum = (red,blue);',
- ' TSetOfEnum = set of TEnum;',
- ' THelper = type helper for TSetOfEnum',
- ' procedure DoIt(e: byte = 123);',
- ' constructor Init(e: TEnum);',
- ' constructor InitEmpty;',
- ' end;',
- 'procedure THelper.DoIt(e: byte);',
- 'begin',
- ' Self:=[];',
- ' Self:=[red];',
- ' Include(Self,blue);',
- 'end;',
- 'constructor THelper.Init(e: TEnum);',
- 'begin',
- ' Self:=[];',
- ' Self:=[e];',
- ' Include(Self,blue);',
- 'end;',
- 'constructor THelper.InitEmpty;',
- 'begin',
- 'end;',
- 'var s: TSetOfEnum;',
- 'begin',
- ' s.DoIt;',
- //' [red].DoIt;',
- //' with s do DoIt;',
- //' with [red,blue] do DoIt;',
- ' s:=TSetOfEnum.Init(blue);',
- ' s:=s.Init(blue);',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_SetType',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.DoIt = function (e) {',
- ' this.set({});',
- ' this.set(rtl.createSet($mod.TEnum.red));',
- ' this.set(rtl.includeSet(this.get(), $mod.TEnum.blue));',
- ' };',
- ' this.Init = function (e) {',
- ' this.set({});',
- ' this.set(rtl.createSet(e));',
- ' this.set(rtl.includeSet(this.get(), $mod.TEnum.blue));',
- ' return this.get();',
- ' };',
- ' this.InitEmpty = function () {',
- ' return this.get();',
- ' };',
- ' this.$new = function (fn, args) {',
- ' return this[fn].apply({',
- ' p: {},',
- ' get: function () {',
- ' return this.p;',
- ' },',
- ' set: function (v) {',
- ' this.p = v;',
- ' }',
- ' }, args);',
- ' };',
- '});',
- 'this.s = {};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.DoIt.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.s;',
- ' },',
- ' set: function (v) {',
- ' this.p.s = v;',
- ' }',
- '}, 123);',
- '$mod.s = rtl.refSet($mod.THelper.$new("Init", [$mod.TEnum.blue]));',
- '$mod.s = rtl.refSet($mod.THelper.Init.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.s;',
- ' },',
- ' set: function (v) {',
- ' this.p.s = v;',
- ' }',
- '}, $mod.TEnum.blue));',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_InterfaceType;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- '{$modeswitch typehelpers}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class(IUnknown)',
- ' function _AddRef: longint; virtual; abstract;',
- ' function _Release: longint; virtual; abstract;',
- ' end;',
- ' THelper = type helper for IUnknown',
- ' procedure Fly(e: byte = 123);',
- ' class procedure Run; static;',
- ' end;',
- 'var',
- ' i: IUnknown;',
- ' o: TObject;',
- 'procedure THelper.Fly(e: byte);',
- 'begin',
- ' i:=Self;',
- ' o:=Self as TObject;',
- ' Self:=nil;',
- ' Self:=i;',
- ' Self:=o;',
- ' with Self do begin',
- ' Fly;',
- ' Fly();',
- ' end;',
- 'end;',
- 'class procedure THelper.Run;',
- 'var l: IUnknown;',
- 'begin',
- ' l.Fly;',
- ' l.Fly();',
- 'end;',
- 'begin',
- ' i.Fly;',
- ' i.Fly();',
- ' i.Run;',
- ' i.Run();',
- ' IUnknown.Run;',
- ' IUnknown.Run();',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_InterfaceType',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Fly = function (e) {',
- ' var $ir = rtl.createIntfRefs();',
- ' try {',
- ' rtl.setIntfP($mod, "i", this.get());',
- ' $mod.o = rtl.intfAsClass(this.get(), $mod.TObject);',
- ' this.set(null);',
- ' this.set($mod.i);',
- ' this.set($ir.ref(1, rtl.queryIntfT($mod.o, $mod.IUnknown)));',
- ' var $with = this.get();',
- ' $mod.THelper.Fly.call(this, 123);',
- ' $mod.THelper.Fly.call(this, 123);',
- ' } finally {',
- ' $ir.free();',
- ' };',
- ' };',
- ' this.Run = function () {',
- ' var l = null;',
- ' try {',
- ' $mod.THelper.Fly.call({',
- ' get: function () {',
- ' return l;',
- ' },',
- ' set: function (v) {',
- ' l = rtl.setIntfL(l, v);',
- ' }',
- ' }, 123);',
- ' $mod.THelper.Fly.call({',
- ' get: function () {',
- ' return l;',
- ' },',
- ' set: function (v) {',
- ' l = rtl.setIntfL(l, v);',
- ' }',
- ' }, 123);',
- ' } finally {',
- ' rtl._Release(l);',
- ' };',
- ' };',
- '});',
- 'this.i = null;',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.Fly.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' rtl.setIntfP(this.p, "i", v);',
- ' }',
- '}, 123);',
- '$mod.THelper.Fly.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' rtl.setIntfP(this.p, "i", v);',
- ' }',
- '}, 123);',
- '$mod.THelper.Run();',
- '$mod.THelper.Run();',
- '$mod.THelper.Run();',
- '$mod.THelper.Run();',
- '']));
- end;
- procedure TTestModule.TestTypeHelper_NestedSelf;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- 'type',
- ' THelper = type helper for string',
- ' procedure Run(Value: string);',
- ' end;',
- 'procedure THelper.Run(Value: string);',
- ' function Sub(i: nativeint): boolean;',
- ' begin',
- ' Result:=Self[i+1]=Value[i];',
- ' end;',
- 'begin',
- ' if Self[3]=Value[4] then ;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestTypeHelper_NestedSelf',
- LinesToStr([ // statements
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.Run = function (Value) {',
- ' var $Self = this;',
- ' function Sub(i) {',
- ' var Result = false;',
- ' Result = $Self.get().charAt((i + 1) - 1) === Value.charAt(i - 1);',
- ' return Result;',
- ' };',
- ' if ($Self.get().charAt(2) === Value.charAt(3)) ;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestProcType;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProcInt = procedure(vI: longint = 1);',
- 'procedure DoIt(vJ: longint);',
- 'begin end;',
- 'var',
- ' b: boolean;',
- ' vP, vQ: tprocint;',
- 'begin',
- ' vp:=nil;',
- ' vp:=vp;',
- ' vp:=@doit;',
- ' vp;',
- ' vp();',
- ' vp(2);',
- ' b:=vp=nil;',
- ' b:=nil=vp;',
- ' b:=vp=vq;',
- ' b:=vp=@doit;',
- ' b:=@doit=vp;',
- ' b:=vp<>nil;',
- ' b:=nil<>vp;',
- ' b:=vp<>vq;',
- ' b:=vp<>@doit;',
- ' b:=@doit<>vp;',
- ' b:=Assigned(vp);',
- ' if Assigned(vp) then ;']);
- ConvertProgram;
- CheckSource('TestProcType',
- LinesToStr([ // statements
- 'this.DoIt = function(vJ) {',
- '};',
- 'this.b = false;',
- 'this.vP = null;',
- 'this.vQ = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.vP = null;',
- '$mod.vP = $mod.vP;',
- '$mod.vP = $mod.DoIt;',
- '$mod.vP(1);',
- '$mod.vP(1);',
- '$mod.vP(2);',
- '$mod.b = $mod.vP === null;',
- '$mod.b = null === $mod.vP;',
- '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
- '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
- '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
- '$mod.b = $mod.vP !== null;',
- '$mod.b = null !== $mod.vP;',
- '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
- '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
- '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
- '$mod.b = $mod.vP != null;',
- 'if ($mod.vP != null) ;',
- '']));
- end;
- procedure TTestModule.TestProcType_Arg;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProcInt = procedure(vI: longint = 1);',
- 'procedure DoIt(vJ: longint); begin end;',
- 'procedure DoSome(vP, vQ: TProcInt);',
- 'var',
- ' b: boolean;',
- 'begin',
- ' vp:=nil;',
- ' vp:=vp;',
- ' vp:=@doit;',
- ' vp;',
- ' vp();',
- ' vp(2);',
- ' b:=vp=nil;',
- ' b:=nil=vp;',
- ' b:=vp=vq;',
- ' b:=vp=@doit;',
- ' b:=@doit=vp;',
- ' b:=vp<>nil;',
- ' b:=nil<>vp;',
- ' b:=vp<>vq;',
- ' b:=vp<>@doit;',
- ' b:=@doit<>vp;',
- ' b:=Assigned(vp);',
- ' if Assigned(vp) then ;',
- 'end;',
- 'begin',
- ' DoSome(@DoIt,nil);']);
- ConvertProgram;
- CheckSource('TestProcType_Arg',
- LinesToStr([ // statements
- 'this.DoIt = function(vJ) {',
- '};',
- 'this.DoSome = function(vP, vQ) {',
- ' var b = false;',
- ' vP = null;',
- ' vP = vP;',
- ' vP = $mod.DoIt;',
- ' vP(1);',
- ' vP(1);',
- ' vP(2);',
- ' b = vP === null;',
- ' b = null === vP;',
- ' b = rtl.eqCallback(vP,vQ);',
- ' b = rtl.eqCallback(vP, $mod.DoIt);',
- ' b = rtl.eqCallback($mod.DoIt, vP);',
- ' b = vP !== null;',
- ' b = null !== vP;',
- ' b = !rtl.eqCallback(vP, vQ);',
- ' b = !rtl.eqCallback(vP, $mod.DoIt);',
- ' b = !rtl.eqCallback($mod.DoIt, vP);',
- ' b = vP != null;',
- ' if (vP != null) ;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoSome($mod.DoIt,null);',
- '']));
- end;
- procedure TTestModule.TestProcType_FunctionFPC;
- begin
- StartProgram(false);
- Add('type');
- Add(' TFuncInt = function(vA: longint = 1): longint;');
- Add('function DoIt(vI: longint): longint;');
- Add('begin end;');
- Add('var');
- Add(' b: boolean;');
- Add(' vP, vQ: tfuncint;');
- Add('begin');
- Add(' vp:=nil;');
- Add(' vp:=vp;');
- Add(' vp:=@doit;'); // ok in fpc and delphi
- //Add(' vp:=doit;'); // illegal in fpc, ok in delphi
- Add(' vp;'); // ok in fpc and delphi
- Add(' vp();');
- Add(' vp(2);');
- Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
- Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
- Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
- Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
- Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
- //Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
- Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
- Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
- Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
- Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
- Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
- Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
- //Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
- Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
- Add(' b:=Assigned(vp);');
- //Add(' doit(vp);'); // illegal in fpc, ok in delphi
- Add(' doit(vp());'); // ok in fpc and delphi
- Add(' doit(vp(2));'); // ok in fpc and delphi
- ConvertProgram;
- CheckSource('TestProcType_FunctionFPC',
- LinesToStr([ // statements
- 'this.DoIt = function(vI) {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.b = false;',
- 'this.vP = null;',
- 'this.vQ = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.vP = null;',
- '$mod.vP = $mod.vP;',
- '$mod.vP = $mod.DoIt;',
- '$mod.vP(1);',
- '$mod.vP(1);',
- '$mod.vP(2);',
- '$mod.b = $mod.vP === null;',
- '$mod.b = null === $mod.vP;',
- '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
- '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
- '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
- '$mod.b = 4 === $mod.vP(1);',
- '$mod.b = $mod.vP !== null;',
- '$mod.b = null !== $mod.vP;',
- '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
- '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
- '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
- '$mod.b = 6 !== $mod.vP(1);',
- '$mod.b = $mod.vP != null;',
- '$mod.DoIt($mod.vP(1));',
- '$mod.DoIt($mod.vP(2));',
- '']));
- end;
- procedure TTestModule.TestProcType_FunctionDelphi;
- begin
- StartProgram(false);
- Add('{$mode Delphi}');
- Add('type');
- Add(' TFuncInt = function(vA: longint = 1): longint;');
- Add('function DoIt(vI: longint): longint;');
- Add('begin end;');
- Add('var');
- Add(' b: boolean;');
- Add(' vP, vQ: tfuncint;');
- Add('begin');
- Add(' vp:=nil;');
- Add(' vp:=vp;');
- Add(' vp:=@doit;'); // ok in fpc and delphi
- Add(' vp:=doit;'); // illegal in fpc, ok in delphi
- Add(' vp;'); // ok in fpc and delphi
- Add(' vp();');
- Add(' vp(2);');
- //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
- //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
- Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
- //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
- //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
- Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
- Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
- //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
- //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
- Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
- //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
- //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
- Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
- Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
- Add(' b:=Assigned(vp);');
- Add(' doit(vp);'); // illegal in fpc, ok in delphi
- Add(' doit(vp());'); // ok in fpc and delphi
- Add(' doit(vp(2));'); // ok in fpc and delphi *)
- ConvertProgram;
- CheckSource('TestProcType_FunctionDelphi',
- LinesToStr([ // statements
- 'this.DoIt = function(vI) {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.b = false;',
- 'this.vP = null;',
- 'this.vQ = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.vP = null;',
- '$mod.vP = $mod.vP;',
- '$mod.vP = $mod.DoIt;',
- '$mod.vP = $mod.DoIt;',
- '$mod.vP(1);',
- '$mod.vP(1);',
- '$mod.vP(2);',
- '$mod.b = $mod.vP(1) === $mod.vQ(1);',
- '$mod.b = $mod.vP(1) === 3;',
- '$mod.b = 4 === $mod.vP(1);',
- '$mod.b = $mod.vP(1) !== $mod.vQ(1);',
- '$mod.b = $mod.vP(1) !== 5;',
- '$mod.b = 6 !== $mod.vP(1);',
- '$mod.b = $mod.vP != null;',
- '$mod.DoIt($mod.vP(1));',
- '$mod.DoIt($mod.vP(1));',
- '$mod.DoIt($mod.vP(2));',
- '']));
- end;
- procedure TTestModule.TestProcType_ProcedureDelphi;
- begin
- StartProgram(false);
- Add('{$mode Delphi}');
- Add('type');
- Add(' TProc = procedure;');
- Add('procedure DoIt;');
- Add('begin end;');
- Add('var');
- Add(' b: boolean;');
- Add(' vP, vQ: tproc;');
- Add('begin');
- Add(' vp:=nil;');
- Add(' vp:=vp;');
- Add(' vp:=vq;');
- 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
- Add(' vp:=doit;'); // illegal in fpc, ok in delphi
- //Add(' vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver
- Add(' vp;'); // ok in fpc and delphi
- Add(' vp();');
- // equal
- //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
- Add(' b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi
- //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
- Add(' b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi
- Add(' b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi
- //Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
- //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
- Add(' b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi
- //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
- Add(' b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi
- // unequal
- //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
- Add(' b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi
- //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
- Add(' b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi
- //Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
- Add(' b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi
- //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
- Add(' b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi
- //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
- Add(' b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi
- Add(' b:=Assigned(vp);');
- ConvertProgram;
- CheckSource('TestProcType_ProcedureDelphi',
- LinesToStr([ // statements
- 'this.DoIt = function() {',
- '};',
- 'this.b = false;',
- 'this.vP = null;',
- 'this.vQ = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.vP = null;',
- '$mod.vP = $mod.vP;',
- '$mod.vP = $mod.vQ;',
- '$mod.vP = $mod.DoIt;',
- '$mod.vP = $mod.DoIt;',
- '$mod.vP();',
- '$mod.vP();',
- '$mod.b = $mod.vP === null;',
- '$mod.b = null === $mod.vP;',
- '$mod.b = rtl.eqCallback($mod.vP, $mod.vQ);',
- '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
- '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
- '$mod.b = $mod.vP !== null;',
- '$mod.b = null !== $mod.vP;',
- '$mod.b = !rtl.eqCallback($mod.vP, $mod.vQ);',
- '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
- '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
- '$mod.b = $mod.vP != null;',
- '']));
- end;
- procedure TTestModule.TestProcType_AsParam;
- begin
- StartProgram(false);
- Add('type');
- Add(' TFuncInt = function(vA: longint = 1): longint;');
- Add('procedure DoIt(vG: tfuncint; const vH: tfuncint; var vI: tfuncint);');
- Add('var vJ: tfuncint;');
- Add('begin');
- Add(' vg:=vg;');
- Add(' vj:=vh;');
- Add(' vi:=vi;');
- Add(' doit(vg,vg,vg);');
- Add(' doit(vh,vh,vj);');
- Add(' doit(vi,vi,vi);');
- Add(' doit(vj,vj,vj);');
- Add('end;');
- Add('var i: tfuncint;');
- Add('begin');
- Add(' doit(i,i,i);');
- ConvertProgram;
- CheckSource('TestProcType_AsParam',
- LinesToStr([ // statements
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = null;',
- ' vG = vG;',
- ' vJ = vH;',
- ' vI.set(vI.get());',
- ' $mod.DoIt(vG, vG, {',
- ' get: function () {',
- ' return vG;',
- ' },',
- ' set: function (v) {',
- ' vG = v;',
- ' }',
- ' });',
- ' $mod.DoIt(vH, vH, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- ' $mod.DoIt(vI.get(), vI.get(), vI);',
- ' $mod.DoIt(vJ, vJ, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- '};',
- 'this.i = null;'
- ]),
- LinesToStr([
- '$mod.DoIt($mod.i,$mod.i,{',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});'
- ]));
- end;
- procedure TTestModule.TestProcType_MethodFPC;
- begin
- StartProgram(false);
- Add('type');
- Add(' TFuncInt = function(vA: longint = 1): longint of object;');
- Add(' TObject = class');
- Add(' function DoIt(vA: longint = 1): longint;');
- Add(' end;');
- Add('function TObject.DoIt(vA: longint = 1): longint;');
- Add('begin');
- Add('end;');
- Add('var');
- Add(' Obj: TObject;');
- Add(' vP: tfuncint;');
- Add(' b: boolean;');
- Add('begin');
- Add(' vp:[email protected];'); // ok in fpc and delphi
- //Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
- Add(' vp;'); // ok in fpc and delphi
- Add(' vp();');
- Add(' vp(2);');
- Add(' b:[email protected];'); // ok in fpc, illegal in delphi
- Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
- Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
- Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
- ConvertProgram;
- CheckSource('TestProcType_MethodFPC',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (vA) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.vP = null;',
- 'this.b = false;'
- ]),
- LinesToStr([
- '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
- '$mod.vP(1);',
- '$mod.vP(1);',
- '$mod.vP(2);',
- '$mod.b = rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.b = rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
- '$mod.b = !rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.b = !rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
- '']));
- end;
- procedure TTestModule.TestProcType_MethodDelphi;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'type',
- ' TFuncInt = function(vA: longint = 1): longint of object;',
- ' TObject = class',
- ' function DoIt(vA: longint = 1): longint;',
- ' end;',
- 'function TObject.DoIt(vA: longint = 1): longint;',
- 'begin',
- 'end;',
- 'var',
- ' Obj: TObject;',
- ' vP: tfuncint;',
- ' b: boolean;',
- 'begin',
- ' vp:[email protected];', // ok in fpc and delphi
- ' vp:=obj.doit;', // illegal in fpc, ok in delphi
- ' vp;', // ok in fpc and delphi
- ' vp();',
- ' vp(2);',
- //' b:[email protected];', // ok in fpc, illegal in delphi
- //' b:[email protected]=vp;', // ok in fpc, illegal in delphi
- //' b:=vp<>@obj.doit;', // ok in fpc, illegal in delphi
- //' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
- '']);
- ConvertProgram;
- CheckSource('TestProcType_MethodDelphi',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (vA) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.vP = null;',
- 'this.b = false;'
- ]),
- LinesToStr([
- '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
- '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
- '$mod.vP(1);',
- '$mod.vP(1);',
- '$mod.vP(2);',
- '']));
- end;
- procedure TTestModule.TestProcType_PropertyFPC;
- begin
- StartProgram(false);
- Add('type');
- Add(' TFuncInt = function(vA: longint = 1): longint of object;');
- Add(' TObject = class');
- Add(' FOnFoo: TFuncInt;');
- Add(' function DoIt(vA: longint = 1): longint;');
- Add(' function GetFoo: TFuncInt;');
- Add(' procedure SetFoo(const Value: TFuncInt);');
- Add(' function GetEvents(Index: longint): TFuncInt;');
- Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
- Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
- Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
- Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
- Add(' end;');
- Add('function tobject.doit(va: longint = 1): longint; begin end;');
- Add('function tobject.getfoo: tfuncint; begin end;');
- Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
- Add('function tobject.getevents(index: longint): tfuncint; begin end;');
- Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
- Add('var');
- Add(' Obj: TObject;');
- Add(' vP: tfuncint;');
- Add(' b: boolean;');
- Add('begin');
- Add(' obj.onfoo:=nil;');
- Add(' obj.onbar:=nil;');
- Add(' obj.events[1]:=nil;');
- Add(' obj.onfoo:=obj.onfoo;');
- Add(' obj.onbar:=obj.onbar;');
- Add(' obj.events[2]:=obj.events[3];');
- Add(' obj.onfoo:[email protected];');
- Add(' obj.onbar:[email protected];');
- Add(' obj.events[4]:[email protected];');
- //Add(' obj.onfoo:=obj.doit;'); // delphi
- //Add(' obj.onbar:=obj.doit;'); // delphi
- //Add(' obj.events[4]:=obj.doit;'); // delphi
- Add(' obj.onfoo;');
- Add(' obj.onbar;');
- //Add(' obj.events[5];'); ToDo in pasresolver
- Add(' obj.onfoo();');
- Add(' obj.onbar();');
- Add(' obj.events[6]();');
- Add(' b:=obj.onfoo=nil;');
- Add(' b:=obj.onbar=nil;');
- Add(' b:=obj.events[7]=nil;');
- Add(' b:=obj.onfoo<>nil;');
- Add(' b:=obj.onbar<>nil;');
- Add(' b:=obj.events[8]<>nil;');
- Add(' b:=obj.onfoo=vp;');
- Add(' b:=obj.onbar=vp;');
- Add(' b:=obj.events[9]=vp;');
- Add(' b:=obj.onfoo=obj.onfoo;');
- Add(' b:=obj.onbar=obj.onfoo;');
- Add(' b:=obj.events[10]=obj.onfoo;');
- Add(' b:=obj.onfoo<>obj.onfoo;');
- Add(' b:=obj.onbar<>obj.onfoo;');
- Add(' b:=obj.events[11]<>obj.onfoo;');
- Add(' b:[email protected];');
- Add(' b:[email protected];');
- Add(' b:=obj.events[12][email protected];');
- Add(' b:=obj.onfoo<>@obj.doit;');
- Add(' b:=obj.onbar<>@obj.doit;');
- Add(' b:=obj.events[12]<>@obj.doit;');
- Add(' b:=Assigned(obj.onfoo);');
- Add(' b:=Assigned(obj.onbar);');
- Add(' b:=Assigned(obj.events[13]);');
- ConvertProgram;
- CheckSource('TestProcType_PropertyFPC',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FOnFoo = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FOnFoo = undefined;',
- ' };',
- ' this.DoIt = function (vA) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- 'this.GetFoo = function () {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.SetFoo = function (Value) {',
- '};',
- 'this.GetEvents = function (Index) {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.SetEvents = function (Index, Value) {',
- '};',
- '});',
- 'this.Obj = null;',
- 'this.vP = null;',
- 'this.b = false;'
- ]),
- LinesToStr([
- '$mod.Obj.FOnFoo = null;',
- '$mod.Obj.SetFoo(null);',
- '$mod.Obj.SetEvents(1, null);',
- '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
- '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
- '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
- '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
- '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.Obj.FOnFoo(1);',
- '$mod.Obj.GetFoo();',
- '$mod.Obj.FOnFoo(1);',
- '$mod.Obj.GetFoo()(1);',
- '$mod.Obj.GetEvents(6)(1);',
- '$mod.b = $mod.Obj.FOnFoo === null;',
- '$mod.b = $mod.Obj.GetFoo() === null;',
- '$mod.b = $mod.Obj.GetEvents(7) === null;',
- '$mod.b = $mod.Obj.FOnFoo !== null;',
- '$mod.b = $mod.Obj.GetFoo() !== null;',
- '$mod.b = $mod.Obj.GetEvents(8) !== null;',
- '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.vP);',
- '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.vP);',
- '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(9), $mod.vP);',
- '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
- '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
- '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(10), $mod.Obj.FOnFoo);',
- '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
- '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
- '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(11), $mod.Obj.FOnFoo);',
- '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.b = $mod.Obj.FOnFoo != null;',
- '$mod.b = $mod.Obj.GetFoo() != null;',
- '$mod.b = $mod.Obj.GetEvents(13) != null;',
- '']));
- end;
- procedure TTestModule.TestProcType_PropertyDelphi;
- begin
- StartProgram(false);
- Add('{$mode delphi}');
- Add('type');
- Add(' TFuncInt = function(vA: longint = 1): longint of object;');
- Add(' TObject = class');
- Add(' FOnFoo: TFuncInt;');
- Add(' function DoIt(vA: longint = 1): longint;');
- Add(' function GetFoo: TFuncInt;');
- Add(' procedure SetFoo(const Value: TFuncInt);');
- Add(' function GetEvents(Index: longint): TFuncInt;');
- Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
- Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
- Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
- Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
- Add(' end;');
- Add('function tobject.doit(va: longint = 1): longint; begin end;');
- Add('function tobject.getfoo: tfuncint; begin end;');
- Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
- Add('function tobject.getevents(index: longint): tfuncint; begin end;');
- Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
- Add('var');
- Add(' Obj: TObject;');
- Add(' vP: tfuncint;');
- Add(' b: boolean;');
- Add('begin');
- Add(' obj.onfoo:=nil;');
- Add(' obj.onbar:=nil;');
- Add(' obj.events[1]:=nil;');
- Add(' obj.onfoo:=obj.onfoo;');
- Add(' obj.onbar:=obj.onbar;');
- Add(' obj.events[2]:=obj.events[3];');
- Add(' obj.onfoo:[email protected];');
- Add(' obj.onbar:[email protected];');
- Add(' obj.events[4]:[email protected];');
- Add(' obj.onfoo:=obj.doit;'); // delphi
- Add(' obj.onbar:=obj.doit;'); // delphi
- Add(' obj.events[4]:=obj.doit;'); // delphi
- Add(' obj.onfoo;');
- Add(' obj.onbar;');
- //Add(' obj.events[5];'); ToDo in pasresolver
- Add(' obj.onfoo();');
- Add(' obj.onbar();');
- Add(' obj.events[6]();');
- //Add(' b:=obj.onfoo=nil;'); // fpc
- //Add(' b:=obj.onbar=nil;'); // fpc
- //Add(' b:=obj.events[7]=nil;'); // fpc
- //Add(' b:=obj.onfoo<>nil;'); // fpc
- //Add(' b:=obj.onbar<>nil;'); // fpc
- //Add(' b:=obj.events[8]<>nil;'); // fpc
- Add(' b:=obj.onfoo=vp;');
- Add(' b:=obj.onbar=vp;');
- //Add(' b:=obj.events[9]=vp;'); ToDo in pasresolver
- Add(' b:=obj.onfoo=obj.onfoo;');
- Add(' b:=obj.onbar=obj.onfoo;');
- //Add(' b:=obj.events[10]=obj.onfoo;'); // ToDo in pasresolver
- Add(' b:=obj.onfoo<>obj.onfoo;');
- Add(' b:=obj.onbar<>obj.onfoo;');
- //Add(' b:=obj.events[11]<>obj.onfoo;'); // ToDo in pasresolver
- //Add(' b:[email protected];'); // fpc
- //Add(' b:[email protected];'); // fpc
- //Add(' b:=obj.events[12][email protected];'); // fpc
- //Add(' b:=obj.onfoo<>@obj.doit;'); // fpc
- //Add(' b:=obj.onbar<>@obj.doit;'); // fpc
- //Add(' b:=obj.events[12]<>@obj.doit;'); // fpc
- Add(' b:=Assigned(obj.onfoo);');
- Add(' b:=Assigned(obj.onbar);');
- Add(' b:=Assigned(obj.events[13]);');
- ConvertProgram;
- CheckSource('TestProcType_PropertyDelphi',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FOnFoo = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FOnFoo = undefined;',
- ' };',
- ' this.DoIt = function (vA) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- 'this.GetFoo = function () {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.SetFoo = function (Value) {',
- '};',
- 'this.GetEvents = function (Index) {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.SetEvents = function (Index, Value) {',
- '};',
- '});',
- 'this.Obj = null;',
- 'this.vP = null;',
- 'this.b = false;'
- ]),
- LinesToStr([
- '$mod.Obj.FOnFoo = null;',
- '$mod.Obj.SetFoo(null);',
- '$mod.Obj.SetEvents(1, null);',
- '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
- '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
- '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
- '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
- '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
- '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
- '$mod.Obj.FOnFoo(1);',
- '$mod.Obj.GetFoo();',
- '$mod.Obj.FOnFoo(1);',
- '$mod.Obj.GetFoo()(1);',
- '$mod.Obj.GetEvents(6)(1);',
- '$mod.b = $mod.Obj.FOnFoo(1) === $mod.vP(1);',
- '$mod.b = $mod.Obj.GetFoo() === $mod.vP(1);',
- '$mod.b = $mod.Obj.FOnFoo(1) === $mod.Obj.FOnFoo(1);',
- '$mod.b = $mod.Obj.GetFoo() === $mod.Obj.FOnFoo(1);',
- '$mod.b = $mod.Obj.FOnFoo(1) !== $mod.Obj.FOnFoo(1);',
- '$mod.b = $mod.Obj.GetFoo() !== $mod.Obj.FOnFoo(1);',
- '$mod.b = $mod.Obj.FOnFoo != null;',
- '$mod.b = $mod.Obj.GetFoo() != null;',
- '$mod.b = $mod.Obj.GetEvents(13) != null;',
- '']));
- end;
- procedure TTestModule.TestProcType_WithClassInstDoPropertyFPC;
- begin
- StartProgram(false);
- Add('type');
- Add(' TFuncInt = function(vA: longint = 1): longint of object;');
- Add(' TObject = class');
- Add(' FOnFoo: TFuncInt;');
- Add(' function DoIt(vA: longint = 1): longint;');
- Add(' function GetFoo: TFuncInt;');
- Add(' procedure SetFoo(const Value: TFuncInt);');
- Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
- Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
- Add(' end;');
- Add('function tobject.doit(va: longint = 1): longint; begin end;');
- Add('function tobject.getfoo: tfuncint; begin end;');
- Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
- Add('var');
- Add(' Obj: TObject;');
- Add(' vP: tfuncint;');
- Add(' b: boolean;');
- Add('begin');
- Add('with obj do begin');
- Add(' fonfoo:=nil;');
- Add(' onfoo:=nil;');
- Add(' onbar:=nil;');
- Add(' fonfoo:=fonfoo;');
- Add(' onfoo:=onfoo;');
- Add(' onbar:=onbar;');
- Add(' fonfoo:=@doit;');
- Add(' onfoo:=@doit;');
- Add(' onbar:=@doit;');
- //Add(' fonfoo:=doit;'); // delphi
- //Add(' onfoo:=doit;'); // delphi
- //Add(' onbar:=doit;'); // delphi
- Add(' fonfoo;');
- Add(' onfoo;');
- Add(' onbar;');
- Add(' fonfoo();');
- Add(' onfoo();');
- Add(' onbar();');
- Add(' b:=fonfoo=nil;');
- Add(' b:=onfoo=nil;');
- Add(' b:=onbar=nil;');
- Add(' b:=fonfoo<>nil;');
- Add(' b:=onfoo<>nil;');
- Add(' b:=onbar<>nil;');
- Add(' b:=fonfoo=vp;');
- Add(' b:=onfoo=vp;');
- Add(' b:=onbar=vp;');
- Add(' b:=fonfoo=fonfoo;');
- Add(' b:=onfoo=onfoo;');
- Add(' b:=onbar=onfoo;');
- Add(' b:=fonfoo<>fonfoo;');
- Add(' b:=onfoo<>onfoo;');
- Add(' b:=onbar<>onfoo;');
- Add(' b:=fonfoo=@doit;');
- Add(' b:=onfoo=@doit;');
- Add(' b:=onbar=@doit;');
- Add(' b:=fonfoo<>@doit;');
- Add(' b:=onfoo<>@doit;');
- Add(' b:=onbar<>@doit;');
- Add(' b:=Assigned(fonfoo);');
- Add(' b:=Assigned(onfoo);');
- Add(' b:=Assigned(onbar);');
- Add('end;');
- ConvertProgram;
- CheckSource('TestProcType_WithClassInstDoPropertyFPC',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FOnFoo = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FOnFoo = undefined;',
- ' };',
- ' this.DoIt = function (vA) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.GetFoo = function () {',
- ' var Result = null;',
- ' return Result;',
- ' };',
- ' this.SetFoo = function (Value) {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.vP = null;',
- 'this.b = false;'
- ]),
- LinesToStr([
- 'var $with = $mod.Obj;',
- '$with.FOnFoo = null;',
- '$with.FOnFoo = null;',
- '$with.SetFoo(null);',
- '$with.FOnFoo = $with.FOnFoo;',
- '$with.FOnFoo = $with.FOnFoo;',
- '$with.SetFoo($with.GetFoo());',
- '$with.FOnFoo = rtl.createCallback($with, "DoIt");',
- '$with.FOnFoo = rtl.createCallback($with, "DoIt");',
- '$with.SetFoo(rtl.createCallback($with, "DoIt"));',
- '$with.FOnFoo(1);',
- '$with.FOnFoo(1);',
- '$with.GetFoo();',
- '$with.FOnFoo(1);',
- '$with.FOnFoo(1);',
- '$with.GetFoo()(1);',
- '$mod.b = $with.FOnFoo === null;',
- '$mod.b = $with.FOnFoo === null;',
- '$mod.b = $with.GetFoo() === null;',
- '$mod.b = $with.FOnFoo !== null;',
- '$mod.b = $with.FOnFoo !== null;',
- '$mod.b = $with.GetFoo() !== null;',
- '$mod.b = rtl.eqCallback($with.FOnFoo, $mod.vP);',
- '$mod.b = rtl.eqCallback($with.FOnFoo, $mod.vP);',
- '$mod.b = rtl.eqCallback($with.GetFoo(), $mod.vP);',
- '$mod.b = rtl.eqCallback($with.FOnFoo, $with.FOnFoo);',
- '$mod.b = rtl.eqCallback($with.FOnFoo, $with.FOnFoo);',
- '$mod.b = rtl.eqCallback($with.GetFoo(), $with.FOnFoo);',
- '$mod.b = !rtl.eqCallback($with.FOnFoo, $with.FOnFoo);',
- '$mod.b = !rtl.eqCallback($with.FOnFoo, $with.FOnFoo);',
- '$mod.b = !rtl.eqCallback($with.GetFoo(), $with.FOnFoo);',
- '$mod.b = rtl.eqCallback($with.FOnFoo, rtl.createCallback($with, "DoIt"));',
- '$mod.b = rtl.eqCallback($with.FOnFoo, rtl.createCallback($with, "DoIt"));',
- '$mod.b = rtl.eqCallback($with.GetFoo(), rtl.createCallback($with, "DoIt"));',
- '$mod.b = !rtl.eqCallback($with.FOnFoo, rtl.createCallback($with, "DoIt"));',
- '$mod.b = !rtl.eqCallback($with.FOnFoo, rtl.createCallback($with, "DoIt"));',
- '$mod.b = !rtl.eqCallback($with.GetFoo(), rtl.createCallback($with, "DoIt"));',
- '$mod.b = $with.FOnFoo != null;',
- '$mod.b = $with.FOnFoo != null;',
- '$mod.b = $with.GetFoo() != null;',
- '']));
- end;
- procedure TTestModule.TestProcType_Nested;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProcInt = procedure(vI: longint = 1);',
- 'procedure DoIt(vJ: longint);',
- 'var aProc: TProcInt;',
- ' b: boolean;',
- ' procedure Sub(vK: longint);',
- ' var aSub: TProcInt;',
- ' procedure SubSub(vK: longint);',
- ' var aSubSub: TProcInt;',
- ' begin;',
- ' aProc:=@DoIt;',
- ' aSub:=@DoIt;',
- ' aSubSub:=@DoIt;',
- ' aProc:=@Sub;',
- ' aSub:=@Sub;',
- ' aSubSub:=@Sub;',
- ' aProc:=@SubSub;',
- ' aSub:=@SubSub;',
- ' aSubSub:=@SubSub;',
- ' end;',
- ' begin;',
- ' end;',
- 'begin;',
- ' aProc:=@Sub;',
- ' b:=aProc=@Sub;',
- ' b:=@Sub=aProc;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestProcType_Nested',
- LinesToStr([ // statements
- 'this.DoIt = function (vJ) {',
- ' var aProc = null;',
- ' var b = false;',
- ' function Sub(vK) {',
- ' var aSub = null;',
- ' function SubSub(vK) {',
- ' var aSubSub = null;',
- ' aProc = $mod.DoIt;',
- ' aSub = $mod.DoIt;',
- ' aSubSub = $mod.DoIt;',
- ' aProc = Sub;',
- ' aSub = Sub;',
- ' aSubSub = Sub;',
- ' aProc = SubSub;',
- ' aSub = SubSub;',
- ' aSubSub = SubSub;',
- ' };',
- ' };',
- ' aProc = Sub;',
- ' b = rtl.eqCallback(aProc, Sub);',
- ' b = rtl.eqCallback(Sub, aProc);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestProcType_NestedOfObject;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProcInt = procedure(vI: longint = 1) of object;',
- ' TObject = class',
- ' procedure DoIt(vJ: longint);',
- ' end;',
- 'procedure TObject.DoIt(vJ: longint);',
- 'var aProc: TProcInt;',
- ' b: boolean;',
- ' procedure Sub(vK: longint);',
- ' var aSub: TProcInt;',
- ' procedure SubSub(vK: longint);',
- ' var aSubSub: TProcInt;',
- ' begin;',
- ' aProc:=@DoIt;',
- ' aSub:=@DoIt;',
- ' aSubSub:=@DoIt;',
- ' aProc:=@Sub;',
- ' aSub:=@Sub;',
- ' aSubSub:=@Sub;',
- ' aProc:=@SubSub;',
- ' aSub:=@SubSub;',
- ' aSubSub:=@SubSub;',
- ' end;',
- ' begin;',
- ' end;',
- 'begin;',
- ' aProc:=@Sub;',
- ' b:=aProc=@Sub;',
- ' b:=@Sub=aProc;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestProcType_Nested',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (vJ) {',
- ' var $Self = this;',
- ' var aProc = null;',
- ' var b = false;',
- ' function Sub(vK) {',
- ' var aSub = null;',
- ' function SubSub(vK) {',
- ' var aSubSub = null;',
- ' aProc = rtl.createCallback($Self, "DoIt");',
- ' aSub = rtl.createCallback($Self, "DoIt");',
- ' aSubSub = rtl.createCallback($Self, "DoIt");',
- ' aProc = Sub;',
- ' aSub = Sub;',
- ' aSubSub = Sub;',
- ' aProc = SubSub;',
- ' aSub = SubSub;',
- ' aSubSub = SubSub;',
- ' };',
- ' };',
- ' aProc = Sub;',
- ' b = rtl.eqCallback(aProc, Sub);',
- ' b = rtl.eqCallback(Sub, aProc);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestProcType_ReferenceToProc;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TProcRef = reference to procedure(i: longint = 0);',
- ' TFuncRef = reference to function(i: longint = 0): longint;',
- 'var',
- ' p: TProcRef;',
- ' f: TFuncRef;',
- 'procedure DoIt(i: longint);',
- 'begin',
- 'end;',
- 'function GetIt(i: longint): longint;',
- 'begin',
- ' p:=@DoIt;',
- ' f:=@GetIt;',
- ' f;',
- ' f();',
- ' f(1);',
- 'end;',
- 'begin',
- ' p:=@DoIt;',
- ' f:=@GetIt;',
- ' f;',
- ' f();',
- ' f(1);',
- ' p:=TProcRef(f);',
- '']);
- ConvertProgram;
- CheckSource('TestProcType_ReferenceToProc',
- LinesToStr([ // statements
- 'this.p = null;',
- 'this.f = null;',
- 'this.DoIt = function (i) {',
- '};',
- 'this.GetIt = function (i) {',
- ' var Result = 0;',
- ' $mod.p = $mod.DoIt;',
- ' $mod.f = $mod.GetIt;',
- ' $mod.f(0);',
- ' $mod.f(0);',
- ' $mod.f(1);',
- ' return Result;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.DoIt;',
- '$mod.f = $mod.GetIt;',
- '$mod.f(0);',
- '$mod.f(0);',
- '$mod.f(1);',
- '$mod.p = $mod.f;',
- '']));
- end;
- procedure TTestModule.TestProcType_ReferenceToMethod;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TFuncRef = reference to function(i: longint = 5): longint;',
- ' TObject = class',
- ' function Grow(s: longint): longint;',
- ' end;',
- 'var',
- ' f: tfuncref;',
- 'function tobject.grow(s: longint): longint;',
- ' function GrowSub(i: longint): longint;',
- ' begin',
- ' f:=@grow;',
- ' f:=@growsub;',
- ' end;',
- 'begin',
- ' f:=@grow;',
- ' f:=@growsub;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestProcType_ReferenceToMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Grow = function (s) {',
- ' var $Self = this;',
- ' var Result = 0;',
- ' function GrowSub(i) {',
- ' var Result = 0;',
- ' $mod.f = rtl.createCallback($Self, "Grow");',
- ' $mod.f = GrowSub;',
- ' return Result;',
- ' };',
- ' $mod.f = rtl.createCallback($Self, "Grow");',
- ' $mod.f = GrowSub;',
- ' return Result;',
- ' };',
- '});',
- 'this.f = null;',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestProcType_Typecast;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TNotifyEvent = procedure(Sender: Pointer) of object;',
- ' TEvent = procedure of object;',
- ' TGetter = function:longint of object;',
- ' TProcA = procedure(i: longint);',
- ' TFuncB = function(i, j: longint): longint;',
- 'procedure DoIt(); varargs; begin end;',
- 'var',
- ' Notify: tnotifyevent;',
- ' Event: tevent;',
- ' Getter: tgetter;',
- ' ProcA: tproca;',
- ' FuncB: tfuncb;',
- ' p: pointer;',
- 'begin',
- ' notify:=tnotifyevent(event);',
- ' event:=tevent(event);',
- ' event:=tevent(notify);',
- ' event:=tevent(getter);',
- ' event:=tevent(proca);',
- ' proca:=tproca(funcb);',
- ' funcb:=tfuncb(funcb);',
- ' funcb:=tfuncb(proca);',
- ' funcb:=tfuncb(getter);',
- ' proca:=tproca(p);',
- ' funcb:=tfuncb(p);',
- ' getter:=tgetter(p);',
- ' p:=pointer(notify);',
- ' p:=notify;',
- ' p:=pointer(proca);',
- ' p:=proca;',
- ' p:=pointer(funcb);',
- ' p:=funcb;',
- ' doit(Pointer(notify),pointer(event),pointer(proca));',
- '']);
- ConvertProgram;
- CheckSource('TestProcType_Typecast',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- '};',
- 'this.Notify = null;',
- 'this.Event = null;',
- 'this.Getter = null;',
- 'this.ProcA = null;',
- 'this.FuncB = null;',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Notify = $mod.Event;',
- '$mod.Event = $mod.Event;',
- '$mod.Event = $mod.Notify;',
- '$mod.Event = $mod.Getter;',
- '$mod.Event = $mod.ProcA;',
- '$mod.ProcA = $mod.FuncB;',
- '$mod.FuncB = $mod.FuncB;',
- '$mod.FuncB = $mod.ProcA;',
- '$mod.FuncB = $mod.Getter;',
- '$mod.ProcA = $mod.p;',
- '$mod.FuncB = $mod.p;',
- '$mod.Getter = $mod.p;',
- '$mod.p = $mod.Notify;',
- '$mod.p = $mod.Notify;',
- '$mod.p = $mod.ProcA;',
- '$mod.p = $mod.ProcA;',
- '$mod.p = $mod.FuncB;',
- '$mod.p = $mod.FuncB;',
- '$mod.DoIt($mod.Notify, $mod.Event, $mod.ProcA);',
- '']));
- end;
- procedure TTestModule.TestProcType_PassProcToUntyped;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TEvent = procedure of object;',
- ' TFunc = function: longint;',
- 'procedure DoIt(); varargs; begin end;',
- 'procedure DoSome(const a; var b; p: pointer); begin end;',
- 'var',
- ' Event: tevent;',
- ' Func: TFunc;',
- 'begin',
- ' doit(event,func);',
- ' dosome(event,event,event);',
- ' dosome(func,func,func);',
- '']);
- ConvertProgram;
- CheckSource('TestProcType_PassProcToUntyped',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- '};',
- 'this.DoSome = function (a, b, p) {',
- '};',
- 'this.Event = null;',
- 'this.Func = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.Event, $mod.Func);',
- '$mod.DoSome($mod.Event, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.Event;',
- ' },',
- ' set: function (v) {',
- ' this.p.Event = v;',
- ' }',
- '}, $mod.Event);',
- '$mod.DoSome($mod.Func, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.Func;',
- ' },',
- ' set: function (v) {',
- ' this.p.Func = v;',
- ' }',
- '}, $mod.Func);',
- '']));
- end;
- procedure TTestModule.TestProcType_PassProcToArray;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TFunc = function: longint;',
- ' TArrFunc = array of TFunc;',
- 'procedure DoIt(Arr: TArrFunc); begin end;',
- 'function GetIt: longint; begin end;',
- 'var',
- ' Func: tfunc;',
- 'begin',
- ' doit([]);',
- ' doit([@GetIt]);',
- ' doit([Func]);',
- '']);
- ConvertProgram;
- CheckSource('TestProcType_PassProcToArray',
- LinesToStr([ // statements
- 'this.DoIt = function (Arr) {',
- '};',
- 'this.GetIt = function () {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.Func = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt([]);',
- '$mod.DoIt([$mod.GetIt]);',
- '$mod.DoIt([$mod.Func]);',
- '']));
- end;
- procedure TTestModule.TestProcType_SafeCallObjFPC;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TProc = reference to procedure(i: longint); safecall;',
- ' TEvent = procedure(i: longint) of object; safecall;',
- ' TExtA = class external name ''ExtObj''',
- ' procedure DoIt(Id: longint = 1); external name ''$Execute'';',
- ' procedure DoSome(Id: longint = 1);',
- ' procedure SetOnClick(const e: TEvent);',
- ' property OnClick: TEvent write SetOnClick;',
- ' class procedure Fly(Id: longint = 1); static;',
- ' procedure SetOnShow(const p: TProc);',
- ' property OnShow: TProc write SetOnShow;',
- ' end;',
- 'procedure Run(i: longint = 1);',
- 'begin',
- 'end;',
- 'var',
- ' Obj: texta;',
- ' e: TEvent;',
- ' p: TProc;',
- 'begin',
- ' e:=e;',
- ' e:[email protected];',
- ' e:[email protected];',
- ' e:=TEvent(@obj.dosome);', // no safecall
- ' obj.OnClick:[email protected];',
- ' obj.OnClick:[email protected];',
- ' obj.setonclick(@obj.doit);',
- ' obj.setonclick(@obj.dosome);',
- ' p:=@Run;',
- ' p:[email protected];',
- ' obj.OnShow:=@Run;',
- ' obj.OnShow:[email protected];',
- ' obj.setOnShow(@Run);',
- ' obj.setOnShow(@TExtA.Fly);',
- ' with obj do begin',
- ' e:=@doit;',
- ' e:=@dosome;',
- ' OnClick:=@doit;',
- ' OnClick:=@dosome;',
- ' setonclick(@doit);',
- ' setonclick(@dosome);',
- ' OnShow:=@Run;',
- ' setOnShow(@Run);',
- ' end;']);
- ConvertProgram;
- CheckSource('TestProcType_SafeCallObjFPC',
- LinesToStr([ // statements
- 'this.Run = function (i) {',
- '};',
- 'this.Obj = null;',
- 'this.e = null;',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.e = $mod.e;',
- '$mod.e = rtl.createSafeCallback($mod.Obj, "$Execute");',
- '$mod.e = rtl.createSafeCallback($mod.Obj, "DoSome");',
- '$mod.e = rtl.createCallback($mod.Obj, "DoSome");',
- '$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "$Execute"));',
- '$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "DoSome"));',
- '$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "$Execute"));',
- '$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "DoSome"));',
- '$mod.p = rtl.createSafeCallback($mod, "Run");',
- '$mod.p = rtl.createSafeCallback(ExtObj, "Fly");',
- '$mod.Obj.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
- '$mod.Obj.SetOnShow(rtl.createSafeCallback(ExtObj, "Fly"));',
- '$mod.Obj.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
- '$mod.Obj.SetOnShow(rtl.createSafeCallback(ExtObj, "Fly"));',
- 'var $with = $mod.Obj;',
- '$mod.e = rtl.createSafeCallback($with, "$Execute");',
- '$mod.e = rtl.createSafeCallback($with, "DoSome");',
- '$with.SetOnClick(rtl.createSafeCallback($with, "$Execute"));',
- '$with.SetOnClick(rtl.createSafeCallback($with, "DoSome"));',
- '$with.SetOnClick(rtl.createSafeCallback($with, "$Execute"));',
- '$with.SetOnClick(rtl.createSafeCallback($with, "DoSome"));',
- '$with.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
- '$with.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
- '']));
- end;
- procedure TTestModule.TestProcType_SafeCallDelphi;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- '{$modeswitch externalclass}',
- 'type',
- ' TProc = reference to procedure(i: longint); safecall;',
- ' TEvent = procedure(i: longint) of object; safecall;',
- ' TExtA = class external name ''ExtObj''',
- ' procedure DoIt(Id: longint = 1); external name ''$Execute'';',
- ' procedure DoSome(Id: longint = 1);',
- ' procedure SetOnClick(const e: TEvent);',
- ' property OnClick: TEvent write SetOnClick;',
- ' class procedure Fly(Id: longint = 1); static;',
- ' procedure SetOnShow(const p: TProc);',
- ' property OnShow: TProc write SetOnShow;',
- ' end;',
- 'procedure Run(i: longint = 1);',
- 'begin',
- 'end;',
- 'var',
- ' Obj: texta;',
- ' e: TEvent;',
- ' p: TProc;',
- 'begin',
- ' e:=e;',
- ' e:=obj.doit;',
- ' e:=obj.dosome;',
- ' e:=TEvent(@obj.dosome);', // no safecall
- ' obj.OnClick:=obj.doit;',
- ' obj.OnClick:=obj.dosome;',
- ' obj.setonclick(obj.doit);',
- ' obj.setonclick(obj.dosome);',
- ' p:=Run;',
- ' p:=TExtA.Fly;',
- ' obj.OnShow:=Run;',
- ' obj.OnShow:=TExtA.Fly;',
- ' obj.setOnShow(Run);',
- ' obj.setOnShow(TExtA.Fly);',
- ' with obj do begin',
- ' e:=doit;',
- ' e:=dosome;',
- ' OnClick:=doit;',
- ' OnClick:=dosome;',
- ' setonclick(doit);',
- ' setonclick(dosome);',
- ' OnShow:=@Run;',
- ' setOnShow(@Run);',
- ' end;']);
- ConvertProgram;
- CheckSource('TestProcType_SafeCallDelphi',
- LinesToStr([ // statements
- 'this.Run = function (i) {',
- '};',
- 'this.Obj = null;',
- 'this.e = null;',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.e = $mod.e;',
- '$mod.e = rtl.createSafeCallback($mod.Obj, "$Execute");',
- '$mod.e = rtl.createSafeCallback($mod.Obj, "DoSome");',
- '$mod.e = rtl.createCallback($mod.Obj, "DoSome");',
- '$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "$Execute"));',
- '$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "DoSome"));',
- '$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "$Execute"));',
- '$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "DoSome"));',
- '$mod.p = rtl.createSafeCallback($mod, "Run");',
- '$mod.p = rtl.createSafeCallback(ExtObj, "Fly");',
- '$mod.Obj.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
- '$mod.Obj.SetOnShow(rtl.createSafeCallback(ExtObj, "Fly"));',
- '$mod.Obj.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
- '$mod.Obj.SetOnShow(rtl.createSafeCallback(ExtObj, "Fly"));',
- 'var $with = $mod.Obj;',
- '$mod.e = rtl.createSafeCallback($with, "$Execute");',
- '$mod.e = rtl.createSafeCallback($with, "DoSome");',
- '$with.SetOnClick(rtl.createSafeCallback($with, "$Execute"));',
- '$with.SetOnClick(rtl.createSafeCallback($with, "DoSome"));',
- '$with.SetOnClick(rtl.createSafeCallback($with, "$Execute"));',
- '$with.SetOnClick(rtl.createSafeCallback($with, "DoSome"));',
- '$with.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
- '$with.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
- '']));
- end;
- procedure TTestModule.TestPointer;
- begin
- StartProgram(false);
- Add(['type',
- ' TObject = class end;',
- ' TClass = class of TObject;',
- ' TArrInt = array of longint;',
- 'const',
- ' n = nil;',
- 'var',
- ' v: jsvalue;',
- ' Obj: tobject;',
- ' C: tclass;',
- ' a: tarrint;',
- ' p: Pointer = nil;',
- ' s: string;',
- 'begin',
- ' p:=p;',
- ' p:=nil;',
- ' if p=nil then;',
- ' if nil=p then;',
- ' if Assigned(p) then;',
- ' p:=Pointer(v);',
- ' p:=obj;',
- ' p:=c;',
- ' p:=a;',
- ' p:=tobject;',
- ' obj:=TObject(p);',
- ' c:=TClass(p);',
- ' a:=TArrInt(p);',
- ' p:=n;',
- ' p:=Pointer(a);',
- ' p:=pointer(s);',
- ' s:=string(p);',
- '']);
- ConvertProgram;
- CheckSource('TestPointer',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.n = null;',
- 'this.v = undefined;',
- 'this.Obj = null;',
- 'this.C = null;',
- 'this.a = [];',
- 'this.p = null;',
- 'this.s = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.p;',
- '$mod.p = null;',
- 'if ($mod.p === null) ;',
- 'if (null === $mod.p) ;',
- 'if ($mod.p != null) ;',
- '$mod.p = $mod.v;',
- '$mod.p = $mod.Obj;',
- '$mod.p = $mod.C;',
- '$mod.p = $mod.a;',
- '$mod.p = $mod.TObject;',
- '$mod.Obj = $mod.p;',
- '$mod.C = $mod.p;',
- '$mod.a = $mod.p;',
- '$mod.p = null;',
- '$mod.p = $mod.a;',
- '$mod.p = $mod.s;',
- '$mod.s = $mod.p;',
- '']));
- end;
- procedure TTestModule.TestPointer_Proc;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' procedure DoIt; virtual; abstract;');
- Add(' end;');
- Add('procedure DoSome; begin end;');
- Add('var');
- Add(' o: TObject;');
- Add(' p: Pointer;');
- Add('begin');
- Add(' p:=@DoSome;');
- Add(' p:[email protected];');
- ConvertProgram;
- CheckSource('TestPointer_Proc',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.DoSome = function () {',
- '};',
- 'this.o = null;',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.DoSome;',
- '$mod.p = rtl.createCallback($mod.o, "DoIt");',
- '']));
- end;
- procedure TTestModule.TestPointer_AssignRecordFail;
- begin
- StartProgram(false);
- Add('type');
- Add(' TRec = record end;');
- Add('var');
- Add(' p: Pointer;');
- Add(' r: TRec;');
- Add('begin');
- Add(' p:=r;');
- SetExpectedPasResolverError('Incompatible types: got "TRec" expected "Pointer"',
- nIncompatibleTypesGotExpected);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_AssignStaticArrayFail;
- begin
- StartProgram(false);
- Add('type');
- Add(' TArr = array[boolean] of longint;');
- Add('var');
- Add(' p: Pointer;');
- Add(' a: TArr;');
- Add('begin');
- Add(' p:=a;');
- SetExpectedPasResolverError('Incompatible types: got "TArr" expected "Pointer"',
- nIncompatibleTypesGotExpected);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_TypeCastJSValueToPointer;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt(args: array of jsvalue); begin end;',
- 'procedure DoAll; varargs; begin end;',
- 'var',
- ' v: jsvalue;',
- 'begin',
- ' DoIt([pointer(v)]);',
- ' DoAll(pointer(v));',
- '']);
- ConvertProgram;
- CheckSource('TestPointer_TypeCastJSValueToPointer',
- LinesToStr([ // statements
- 'this.DoIt = function (args) {',
- '};',
- 'this.DoAll = function () {',
- '};',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt([$mod.v]);',
- '$mod.DoAll($mod.v);',
- '']));
- end;
- procedure TTestModule.TestPointer_NonRecordFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' p = ^longint;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Not supported: pointer of Longint',nNotSupportedX);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_AnonymousArgTypeFail;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt(p: ^longint); begin end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_AnonymousVarTypeFail;
- begin
- StartProgram(false);
- Add([
- 'var p: ^longint;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_AnonymousResultTypeFail;
- begin
- StartProgram(false);
- Add([
- 'function DoIt: ^longint; begin end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_AddrOperatorFail;
- begin
- StartProgram(false);
- Add([
- 'var i: longint;',
- 'begin',
- ' if @i=nil then ;',
- '']);
- SetExpectedConverterError('illegal qualifier "@" in front of "i:Longint"',nIllegalQualifierInFrontOf);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_ArrayParamsFail;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' p: Pointer;',
- 'begin',
- ' p:=p[1];',
- '']);
- SetExpectedPasResolverError('illegal qualifier "[" after "Pointer"',nIllegalQualifierAfter);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_PointerAddFail;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' p: Pointer;',
- 'begin',
- ' p:=p+1;',
- '']);
- SetExpectedPasResolverError('Operator is not overloaded: "Pointer" + "Longint"',nOperatorIsNotOverloadedAOpB);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_IncPointerFail;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' p: Pointer;',
- 'begin',
- ' inc(p,1);',
- '']);
- SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Pointer", expected "integer"',
- nIncompatibleTypeArgNo);
- ConvertProgram;
- end;
- procedure TTestModule.TestPointer_Record;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TRec = record x: longint; end;',
- ' PRec = ^TRec;',
- 'var',
- ' r: TRec;',
- ' p: PRec;',
- ' q: ^TRec;',
- ' Ptr: pointer;',
- 'begin',
- ' new(p);',
- ' p:=@r;',
- ' r:=p^;',
- ' r.x:=p^.x;',
- ' p^.x:=r.x;',
- ' if p^.x=3 then ;',
- ' if 4=p^.x then ;',
- ' dispose(p);',
- ' new(q);',
- ' dispose(q);',
- ' Ptr:=p;',
- ' p:=PRec(ptr);',
- '']);
- ConvertProgram;
- CheckSource('TestPointer_Record',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.x = 0;',
- ' this.$eq = function (b) {',
- ' return this.x === b.x;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' return this;',
- ' };',
- '});',
- 'this.r = this.TRec.$new();',
- 'this.p = null;',
- 'this.q = null;',
- 'this.Ptr = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.TRec.$new();',
- '$mod.p = $mod.r;',
- '$mod.r.$assign($mod.p);',
- '$mod.r.x = $mod.p.x;',
- '$mod.p.x = $mod.r.x;',
- 'if ($mod.p.x === 3) ;',
- 'if (4 === $mod.p.x) ;',
- '$mod.p = null;',
- '$mod.q = $mod.TRec.$new();',
- '$mod.q = null;',
- '$mod.Ptr = $mod.p;',
- '$mod.p = $mod.Ptr;',
- '']));
- end;
- procedure TTestModule.TestPointer_RecordArg;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch autoderef}',
- 'type',
- ' TRec = record x: longint; end;',
- ' PRec = ^TRec;',
- 'function DoIt(const a: PRec; var b: PRec; out c: PRec): TRec;',
- 'begin',
- ' a.x:=a.x;',
- ' a^.x:=a^.x;',
- ' with a^ do',
- ' x:=x;',
- 'end;',
- 'function GetIt(p: PRec): PRec;',
- 'begin',
- ' p.x:=p.x;',
- ' p^.x:=p^.x;',
- ' with p^ do',
- ' x:=x;',
- 'end;',
- 'var',
- ' r: TRec;',
- ' p: PRec;',
- 'begin',
- ' p:=GetIt(p);',
- ' p^:=GetIt(@r)^;',
- ' DoIt(p,p,p);',
- ' DoIt(@r,p,p);',
- '']);
- ConvertProgram;
- CheckSource('TestPointer_RecordArg',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.x = 0;',
- ' this.$eq = function (b) {',
- ' return this.x === b.x;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' return this;',
- ' };',
- '});',
- 'this.DoIt = function (a, b, c) {',
- ' var Result = $mod.TRec.$new();',
- ' a.x = a.x;',
- ' a.x = a.x;',
- ' a.x = a.x;',
- ' return Result;',
- '};',
- 'this.GetIt = function (p) {',
- ' var Result = null;',
- ' p.x = p.x;',
- ' p.x = p.x;',
- ' p.x = p.x;',
- ' return Result;',
- '};',
- 'this.r = this.TRec.$new();',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.GetIt($mod.p);',
- '$mod.p.$assign($mod.GetIt($mod.r));',
- '$mod.DoIt($mod.p, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.p;',
- ' },',
- ' set: function (v) {',
- ' this.p.p = v;',
- ' }',
- '}, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.p;',
- ' },',
- ' set: function (v) {',
- ' this.p.p = v;',
- ' }',
- '});',
- '$mod.DoIt($mod.r, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.p;',
- ' },',
- ' set: function (v) {',
- ' this.p.p = v;',
- ' }',
- '}, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.p;',
- ' },',
- ' set: function (v) {',
- ' this.p.p = v;',
- ' }',
- '});',
- '']));
- end;
- procedure TTestModule.TestJSValue_AssignToJSValue;
- begin
- StartProgram(false);
- Add('var');
- Add(' v: jsvalue;');
- Add(' i: longint;');
- Add(' s: string;');
- Add(' b: boolean;');
- Add(' d: double;');
- Add(' p: pointer;');
- Add('begin');
- Add(' v:=v;');
- Add(' v:=1;');
- Add(' v:=i;');
- Add(' v:='''';');
- Add(' v:=''c'';');
- Add(' v:=''foo'';');
- Add(' v:=s;');
- Add(' v:=false;');
- Add(' v:=true;');
- Add(' v:=b;');
- Add(' v:=0.1;');
- Add(' v:=d;');
- Add(' v:=nil;');
- Add(' v:=p;');
- ConvertProgram;
- CheckSource('TestJSValue_AssignToJSValue',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.i = 0;',
- 'this.s = "";',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.v;',
- '$mod.v = 1;',
- '$mod.v = $mod.i;',
- '$mod.v = "";',
- '$mod.v = "c";',
- '$mod.v = "foo";',
- '$mod.v = $mod.s;',
- '$mod.v = false;',
- '$mod.v = true;',
- '$mod.v = $mod.b;',
- '$mod.v = 0.1;',
- '$mod.v = $mod.d;',
- '$mod.v = null;',
- '$mod.v = $mod.p;',
- '']));
- end;
- procedure TTestModule.TestJSValue_TypeCastToBaseType;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TYesNo = boolean;');
- Add(' TFloat = double;');
- Add(' TCaption = string;');
- Add(' TChar = char;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' i: integer;');
- Add(' s: TCaption;');
- Add(' b: TYesNo;');
- Add(' d: TFloat;');
- Add(' c: char;');
- Add('begin');
- Add(' i:=longint(v);');
- Add(' i:=integer(v);');
- Add(' s:=string(v);');
- Add(' s:=TCaption(v);');
- Add(' b:=boolean(v);');
- Add(' b:=TYesNo(v);');
- Add(' d:=double(v);');
- Add(' d:=TFloat(v);');
- Add(' c:=char(v);');
- Add(' c:=TChar(v);');
- ConvertProgram;
- CheckSource('TestJSValue_TypeCastToBaseType',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.i = 0;',
- 'this.s = "";',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.c = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.i = rtl.trunc($mod.v);',
- '$mod.i = rtl.trunc($mod.v);',
- '$mod.s = "" + $mod.v;',
- '$mod.s = "" + $mod.v;',
- '$mod.b = !($mod.v == false);',
- '$mod.b = !($mod.v == false);',
- '$mod.d = rtl.getNumber($mod.v);',
- '$mod.d = rtl.getNumber($mod.v);',
- '$mod.c = rtl.getChar($mod.v);',
- '$mod.c = rtl.getChar($mod.v);',
- '']));
- end;
- procedure TTestModule.TestJSValue_TypecastToJSValue;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArr = array of word;',
- ' TRec = record end;',
- ' TSet = set of boolean;',
- 'procedure Fly(v: jsvalue);',
- 'begin',
- 'end;',
- 'var',
- ' a: TArr;',
- ' r: TRec;',
- ' s: TSet;',
- 'begin',
- ' Fly(jsvalue(a));',
- ' Fly(jsvalue(r));',
- ' Fly(jsvalue(s));',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_TypecastToJSValue',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- '});',
- 'this.Fly = function (v) {',
- '};',
- 'this.a = [];',
- 'this.r = this.TRec.$new();',
- 'this.s = {};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Fly($mod.a);',
- '$mod.Fly($mod.r);',
- '$mod.Fly($mod.s);',
- '']));
- end;
- procedure TTestModule.TestJSValue_Equal;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TYesNo = boolean;');
- Add(' TFloat = double;');
- Add(' TCaption = string;');
- Add(' TChar = char;');
- Add(' TMulti = JSValue;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' i: integer;');
- Add(' s: TCaption;');
- Add(' b: TYesNo;');
- Add(' d: TFloat;');
- Add(' c: char;');
- Add(' m: TMulti;');
- Add('begin');
- Add(' b:=v=v;');
- Add(' b:=v<>v;');
- Add(' b:=v=1;');
- Add(' b:=v<>1;');
- Add(' b:=2=v;');
- Add(' b:=2<>v;');
- Add(' b:=v=i;');
- Add(' b:=i=v;');
- Add(' b:=v=nil;');
- Add(' b:=nil=v;');
- Add(' b:=v=false;');
- Add(' b:=true=v;');
- Add(' b:=v=b;');
- Add(' b:=b=v;');
- Add(' b:=v=s;');
- Add(' b:=s=v;');
- Add(' b:=v=''foo'';');
- Add(' b:=''''=v;');
- Add(' b:=v=d;');
- Add(' b:=d=v;');
- Add(' b:=v=3.4;');
- Add(' b:=5.6=v;');
- Add(' b:=v=c;');
- Add(' b:=c=v;');
- Add(' b:=m=m;');
- Add(' b:=v=m;');
- Add(' b:=m=v;');
- ConvertProgram;
- CheckSource('TestJSValue_Equal',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.i = 0;',
- 'this.s = "";',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.c = "";',
- 'this.m = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.b = $mod.v == $mod.v;',
- '$mod.b = $mod.v != $mod.v;',
- '$mod.b = $mod.v == 1;',
- '$mod.b = $mod.v != 1;',
- '$mod.b = 2 == $mod.v;',
- '$mod.b = 2 != $mod.v;',
- '$mod.b = $mod.v == $mod.i;',
- '$mod.b = $mod.i == $mod.v;',
- '$mod.b = $mod.v == null;',
- '$mod.b = null == $mod.v;',
- '$mod.b = $mod.v == false;',
- '$mod.b = true == $mod.v;',
- '$mod.b = $mod.v == $mod.b;',
- '$mod.b = $mod.b == $mod.v;',
- '$mod.b = $mod.v == $mod.s;',
- '$mod.b = $mod.s == $mod.v;',
- '$mod.b = $mod.v == "foo";',
- '$mod.b = "" == $mod.v;',
- '$mod.b = $mod.v == $mod.d;',
- '$mod.b = $mod.d == $mod.v;',
- '$mod.b = $mod.v == 3.4;',
- '$mod.b = 5.6 == $mod.v;',
- '$mod.b = $mod.v == $mod.c;',
- '$mod.b = $mod.c == $mod.v;',
- '$mod.b = $mod.m == $mod.m;',
- '$mod.b = $mod.v == $mod.m;',
- '$mod.b = $mod.m == $mod.v;',
- '']));
- end;
- procedure TTestModule.TestJSValue_If;
- begin
- StartProgram(false);
- Add([
- 'procedure Fly(var u);',
- 'begin',
- ' if jsvalue(u) then ;',
- 'end;',
- 'var',
- ' v: jsvalue;',
- 'begin',
- ' if v then ;',
- ' while v do ;',
- ' repeat until v;',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_If',
- LinesToStr([ // statements
- 'this.Fly = function (u) {',
- ' if (u.get()) ;',
- '};',
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- 'if ($mod.v) ;',
- 'while($mod.v){',
- '};',
- 'do{',
- '} while(!$mod.v);',
- '']));
- end;
- procedure TTestModule.TestJSValue_Not;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' v: jsvalue;',
- ' b: boolean;',
- 'begin',
- ' b:=not v;',
- ' if not v then ;',
- ' while not v do ;',
- ' repeat until not v;',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_If',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.b = false;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.b=!$mod.v;',
- 'if (!$mod.v) ;',
- 'while(!$mod.v){',
- '};',
- 'do{',
- '} while($mod.v);',
- '']));
- end;
- procedure TTestModule.TestJSValue_Enum;
- begin
- StartProgram(false);
- Add('type');
- Add(' TColor = (red, blue);');
- Add(' TRedBlue = TColor;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' e: TColor;');
- Add('begin');
- Add(' v:=e;');
- Add(' v:=TColor(e);');
- Add(' v:=TRedBlue(e);');
- Add(' e:=TColor(v);');
- Add(' e:=TRedBlue(v);');
- ConvertProgram;
- CheckSource('TestJSValue_Enum',
- LinesToStr([ // statements
- 'this.TColor = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'this.v = undefined;',
- 'this.e = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.e;',
- '$mod.v = $mod.e;',
- '$mod.v = $mod.e;',
- '$mod.e = $mod.v;',
- '$mod.e = $mod.v;',
- '']));
- end;
- procedure TTestModule.TestJSValue_ClassInstance;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' end;',
- ' TBirdObject = TObject;',
- 'var',
- ' v: jsvalue;',
- ' o: TObject;',
- 'begin',
- ' v:=o;',
- ' v:=TObject(o);',
- ' v:=TBirdObject(o);',
- ' o:=TObject(v);',
- ' o:=TBirdObject(v);',
- ' if v is TObject then ;',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_ClassInstance',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.v = undefined;',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.o;',
- '$mod.v = $mod.o;',
- '$mod.v = $mod.o;',
- '$mod.o = rtl.getObject($mod.v);',
- '$mod.o = rtl.getObject($mod.v);',
- 'if (rtl.isExt($mod.v, $mod.TObject, 1)) ;',
- '']));
- end;
- procedure TTestModule.TestJSValue_ClassOf;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TClass = class of TObject;',
- ' TObject = class',
- ' end;',
- ' TBirds = class of TBird;',
- ' TBird = class(TObject) end;',
- 'var',
- ' v: jsvalue;',
- ' c: TClass;',
- 'begin',
- ' v:=c;',
- ' v:=TObject;',
- ' v:=TClass(c);',
- ' v:=TBirds(c);',
- ' c:=TClass(v);',
- ' c:=TBirds(v);',
- ' if v is TClass then ;',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_ClassOf',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- '});',
- 'this.v = undefined;',
- 'this.c = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.c;',
- '$mod.v = $mod.TObject;',
- '$mod.v = $mod.c;',
- '$mod.v = $mod.c;',
- '$mod.c = rtl.getObject($mod.v);',
- '$mod.c = rtl.getObject($mod.v);',
- 'if (rtl.isExt($mod.v, $mod.TObject, 2)) ;',
- '']));
- end;
- procedure TTestModule.TestJSValue_ArrayOfJSValue;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' TArray = array of JSValue;',
- ' TArrgh = tarray;',
- ' TArrInt = array of integer;',
- 'var',
- ' v: jsvalue;',
- ' TheArray: tarray = (1,''2'');',
- ' Arr: tarrgh;',
- ' i: integer;',
- ' ArrInt: tarrint;',
- 'begin',
- ' arr:=thearray;',
- ' thearray:=arr;',
- ' setlength(arr,2);',
- ' setlength(thearray,3);',
- ' arr[4]:=v;',
- ' arr[5]:=length(thearray);',
- ' arr[6]:=nil;',
- ' arr[7]:=thearray[8];',
- ' arr[low(arr)]:=high(thearray);',
- ' arr:=arrint;',
- ' arrInt:=tarrint(arr);',
- ' if TheArray = nil then ;',
- ' if nil = TheArray then ;',
- ' if TheArray <> nil then ;',
- ' if nil <> TheArray then ;',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_ArrayOfJSValue',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.TheArray = [1, "2"];',
- 'this.Arr = [];',
- 'this.i = 0;',
- 'this.ArrInt = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Arr = rtl.arrayRef($mod.TheArray);',
- '$mod.TheArray = rtl.arrayRef($mod.Arr);',
- '$mod.Arr = rtl.arraySetLength($mod.Arr,undefined,2);',
- '$mod.TheArray = rtl.arraySetLength($mod.TheArray,undefined,3);',
- '$mod.Arr[4] = $mod.v;',
- '$mod.Arr[5] = rtl.length($mod.TheArray);',
- '$mod.Arr[6] = null;',
- '$mod.Arr[7] = $mod.TheArray[8];',
- '$mod.Arr[0] = rtl.length($mod.TheArray) - 1;',
- '$mod.Arr = rtl.arrayRef($mod.ArrInt);',
- '$mod.ArrInt = $mod.Arr;',
- 'if (rtl.length($mod.TheArray) === 0) ;',
- 'if (rtl.length($mod.TheArray) === 0) ;',
- 'if (rtl.length($mod.TheArray) > 0) ;',
- 'if (rtl.length($mod.TheArray) > 0) ;',
- '']));
- end;
- procedure TTestModule.TestJSValue_ArrayLit;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TFlag = (big,small);',
- ' TArray = array of JSValue;',
- ' TObject = class end;',
- ' TClass = class of TObject;',
- 'var',
- ' v: jsvalue;',
- ' a: TArray;',
- ' o: TObject;',
- 'begin',
- ' a:=[];',
- ' a:=[1];',
- ' a:=[1,2];',
- ' a:=[big];',
- ' a:=[1,big];',
- ' a:=[o,nil];',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_ArrayLit',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "big",',
- ' big: 0,',
- ' "1": "small",',
- ' small: 1',
- '};',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.v = undefined;',
- 'this.a = [];',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.a = [];',
- '$mod.a = [1];',
- '$mod.a = [1, 2];',
- '$mod.a = [$mod.TFlag.big];',
- '$mod.a = [1, $mod.TFlag.big];',
- '$mod.a = [$mod.o, null];',
- '']));
- end;
- procedure TTestModule.TestJSValue_Params;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TYesNo = boolean;');
- Add(' TFloat = double;');
- Add(' TCaption = string;');
- Add(' TChar = char;');
- Add('function DoIt(a: jsvalue; const b: jsvalue; var c: jsvalue; out d: jsvalue): jsvalue;');
- Add('var');
- Add(' l: jsvalue;');
- Add('begin');
- Add(' a:=a;');
- Add(' l:=b;');
- Add(' c:=c;');
- Add(' d:=d;');
- Add(' Result:=l;');
- Add('end;');
- Add('function DoSome(a: jsvalue; const b: jsvalue): jsvalue; begin end;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' i: integer;');
- Add(' b: TYesNo;');
- Add(' d: TFloat;');
- Add(' s: TCaption;');
- Add(' c: TChar;');
- Add('begin');
- Add(' v:=doit(v,v,v,v);');
- Add(' i:=integer(dosome(i,i));');
- Add(' b:=TYesNo(dosome(b,b));');
- Add(' d:=TFloat(dosome(d,d));');
- Add(' s:=TCaption(dosome(s,s));');
- Add(' c:=TChar(dosome(c,c));');
- ConvertProgram;
- CheckSource('TestJSValue_Params',
- LinesToStr([ // statements
- 'this.DoIt = function (a, b, c, d) {',
- ' var Result = undefined;',
- ' var l = undefined;',
- ' a = a;',
- ' l = b;',
- ' c.set(c.get());',
- ' d.set(d.get());',
- ' Result = l;',
- ' return Result;',
- '};',
- 'this.DoSome = function (a, b) {',
- ' var Result = undefined;',
- ' return Result;',
- '};',
- 'this.v = undefined;',
- 'this.i = 0;',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.s = "";',
- 'this.c = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.DoIt($mod.v, $mod.v, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.v;',
- ' },',
- ' set: function (v) {',
- ' this.p.v = v;',
- ' }',
- '}, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.v;',
- ' },',
- ' set: function (v) {',
- ' this.p.v = v;',
- ' }',
- '});',
- '$mod.i = rtl.trunc($mod.DoSome($mod.i, $mod.i));',
- '$mod.b = !($mod.DoSome($mod.b, $mod.b) == false);',
- '$mod.d = rtl.getNumber($mod.DoSome($mod.d, $mod.d));',
- '$mod.s = "" + $mod.DoSome($mod.s, $mod.s);',
- '$mod.c = rtl.getChar($mod.DoSome($mod.c, $mod.c));',
- '']));
- end;
- procedure TTestModule.TestJSValue_UntypedParam;
- begin
- StartProgram(false);
- Add('function DoIt(const a; var b; out c): jsvalue;');
- Add('begin');
- Add(' Result:=a;');
- Add(' Result:=b;');
- Add(' Result:=c;');
- Add(' b:=Result;');
- Add(' c:=Result;');
- Add('end;');
- Add('var i: longint;');
- Add('begin');
- Add(' doit(i,i,i);');
- ConvertProgram;
- CheckSource('TestJSValue_UntypedParam',
- LinesToStr([ // statements
- 'this.DoIt = function (a, b, c) {',
- ' var Result = undefined;',
- ' Result = a;',
- ' Result = b.get();',
- ' Result = c.get();',
- ' b.set(Result);',
- ' c.set(Result);',
- ' return Result;',
- '};',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.i, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '}, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});',
- '']));
- end;
- procedure TTestModule.TestJSValue_FuncResultType;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TJSValueArray = array of JSValue;');
- Add(' TListSortCompare = function(Item1, Item2: JSValue): Integer;');
- Add('procedure Sort(P: JSValue; aList: TJSValueArray; const Compare: TListSortCompare);');
- Add('begin');
- Add(' while Compare(P,aList[0])>0 do ;');
- Add('end;');
- Add('var');
- Add(' Compare: TListSortCompare;');
- Add(' V: JSValue;');
- Add(' i: integer;');
- Add('begin');
- Add(' if Compare(V,V)>0 then ;');
- Add(' if Compare(i,i)>1 then ;');
- Add(' if Compare(nil,false)>2 then ;');
- Add(' if Compare(1,true)>3 then ;');
- ConvertProgram;
- CheckSource('TestJSValue_UntypedParam',
- LinesToStr([ // statements
- 'this.Sort = function (P, aList, Compare) {',
- ' while (Compare(P, aList[0]) > 0) {',
- ' };',
- '};',
- 'this.Compare = null;',
- 'this.V = undefined;',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- 'if ($mod.Compare($mod.V, $mod.V) > 0) ;',
- 'if ($mod.Compare($mod.i, $mod.i) > 1) ;',
- 'if ($mod.Compare(null, false) > 2) ;',
- 'if ($mod.Compare(1, true) > 3) ;',
- '']));
- end;
- procedure TTestModule.TestJSValue_ProcType_Assign;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TObject = class');
- Add(' class function GetGlob: integer;');
- Add(' function Getter: integer;');
- Add(' end;');
- Add('class function TObject.GetGlob: integer;');
- Add('var v1: jsvalue;');
- Add('begin');
- Add(' v1:=@GetGlob;');
- Add(' v1:[email protected];');
- Add('end;');
- Add('function TObject.Getter: integer;');
- Add('var v2: jsvalue;');
- Add('begin');
- Add(' v2:=@Getter;');
- Add(' v2:[email protected];');
- Add(' v2:=@GetGlob;');
- Add(' v2:[email protected];');
- Add('end;');
- Add('function GetIt(i: integer): integer;');
- Add('var v3: jsvalue;');
- Add('begin');
- Add(' v3:=@GetIt;');
- Add('end;');
- Add('var');
- Add(' V: JSValue;');
- Add(' o: TObject;');
- Add('begin');
- Add(' v:=@GetIt;');
- Add(' v:[email protected];');
- Add(' v:[email protected];');
- ConvertProgram;
- CheckSource('TestJSValue_ProcType_Assign',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetGlob = function () {',
- ' var Result = 0;',
- ' var v1 = undefined;',
- ' v1 = rtl.createCallback(this, "GetGlob");',
- ' v1 = rtl.createCallback(this, "GetGlob");',
- ' return Result;',
- ' };',
- ' this.Getter = function () {',
- ' var Result = 0;',
- ' var v2 = undefined;',
- ' v2 = rtl.createCallback(this, "Getter");',
- ' v2 = rtl.createCallback(this, "Getter");',
- ' v2 = rtl.createCallback(this.$class, "GetGlob");',
- ' v2 = rtl.createCallback(this.$class, "GetGlob");',
- ' return Result;',
- ' };',
- '});',
- 'this.GetIt = function (i) {',
- ' var Result = 0;',
- ' var v3 = undefined;',
- ' v3 = $mod.GetIt;',
- ' return Result;',
- '};',
- 'this.V = undefined;',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.V = $mod.GetIt;',
- '$mod.V = rtl.createCallback($mod.o, "Getter");',
- '$mod.V = rtl.createCallback($mod.o.$class, "GetGlob");',
- '']));
- end;
- procedure TTestModule.TestJSValue_ProcType_Equal;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TObject = class');
- Add(' class function GetGlob: integer;');
- Add(' function Getter: integer;');
- Add(' end;');
- Add('class function TObject.GetGlob: integer;');
- Add('var v1: jsvalue;');
- Add('begin');
- Add(' if v1=@GetGlob then;');
- Add(' if [email protected] then ;');
- Add('end;');
- Add('function TObject.Getter: integer;');
- Add('var v2: jsvalue;');
- Add('begin');
- Add(' if v2=@Getter then;');
- Add(' if [email protected] then ;');
- Add(' if v2=@GetGlob then;');
- Add(' if [email protected] then;');
- Add('end;');
- Add('function GetIt(i: integer): integer;');
- Add('var v3: jsvalue;');
- Add('begin');
- Add(' if v3=@GetIt then;');
- Add('end;');
- Add('var');
- Add(' V: JSValue;');
- Add(' o: TObject;');
- Add('begin');
- Add(' if v=@GetIt then;');
- Add(' if [email protected] then;');
- Add(' if [email protected] then;');
- Add(' if @GetIt=v then;');
- Add(' if @o.Getter=v then;');
- Add(' if @o.GetGlob=v then;');
- ConvertProgram;
- CheckSource('TestJSValue_ProcType_Equal',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetGlob = function () {',
- ' var Result = 0;',
- ' var v1 = undefined;',
- ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
- ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
- ' return Result;',
- ' };',
- ' this.Getter = function () {',
- ' var Result = 0;',
- ' var v2 = undefined;',
- ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
- ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
- ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
- ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
- ' return Result;',
- ' };',
- '});',
- 'this.GetIt = function (i) {',
- ' var Result = 0;',
- ' var v3 = undefined;',
- ' if (rtl.eqCallback(v3, $mod.GetIt)) ;',
- ' return Result;',
- '};',
- 'this.V = undefined;',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'if (rtl.eqCallback($mod.V, $mod.GetIt)) ;',
- 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o, "Getter"))) ;',
- 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o.$class, "GetGlob"))) ;',
- 'if (rtl.eqCallback($mod.GetIt, $mod.V)) ;',
- 'if (rtl.eqCallback(rtl.createCallback($mod.o, "Getter"), $mod.V)) ;',
- 'if (rtl.eqCallback(rtl.createCallback($mod.o.$class, "GetGlob"), $mod.V)) ;',
- '']));
- end;
- procedure TTestModule.TestJSValue_ProcType_Param;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' variant = jsvalue;',
- ' TArrVariant = array of variant;',
- ' TArrVar2 = TArrVariant;',
- ' TFuncInt = function: longint;',
- 'function GetIt: longint;',
- 'begin',
- 'end;',
- 'procedure DoIt(p: jsvalue; Arr: TArrVar2);',
- 'var v: variant;',
- 'begin',
- ' v:=arr[1];',
- 'end;',
- 'var s: string;',
- 'begin',
- ' DoIt(GetIt,[]);',
- ' DoIt(@GetIt,[]);',
- ' DoIt(1,[s,GetIt]);',
- ' DoIt(1,[s,@GetIt]);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_ProcType_Param',
- LinesToStr([ // statements
- 'this.GetIt = function () {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.DoIt = function (p, Arr) {',
- ' var v = undefined;',
- ' v = Arr[1];',
- '};',
- 'this.s = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.GetIt(), []);',
- '$mod.DoIt($mod.GetIt, []);',
- '$mod.DoIt(1, [$mod.s, $mod.GetIt()]);',
- '$mod.DoIt(1, [$mod.s, $mod.GetIt]);',
- '']));
- end;
- procedure TTestModule.TestJSValue_AssignToPointerFail;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' v: JSValue;',
- ' p: Pointer;',
- 'begin',
- ' p:=v;',
- '']);
- SetExpectedPasResolverError('Incompatible types: got "JSValue" expected "Pointer"',
- nIncompatibleTypesGotExpected);
- ConvertProgram;
- end;
- procedure TTestModule.TestJSValue_OverloadDouble;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' tdatetime = double;',
- 'procedure DoIt(d: double); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' d: double;',
- ' dt: tdatetime;',
- ' i: integer;',
- ' b: byte;',
- ' shi: shortint;',
- ' w: word;',
- ' smi: smallint;',
- ' lw: longword;',
- ' li: longint;',
- ' ni: nativeint;',
- ' nu: nativeuint;',
- 'begin',
- ' DoIt(d);',
- ' DoIt(dt);',
- ' DoIt(i);',
- ' DoIt(b);',
- ' DoIt(shi);',
- ' DoIt(w);',
- ' DoIt(smi);',
- ' DoIt(lw);',
- ' DoIt(li);',
- ' DoIt(ni);',
- ' DoIt(nu);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadDouble',
- LinesToStr([ // statements
- 'this.DoIt = function (d) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.d = 0.0;',
- 'this.dt = 0.0;',
- 'this.i = 0;',
- 'this.b = 0;',
- 'this.shi = 0;',
- 'this.w = 0;',
- 'this.smi = 0;',
- 'this.lw = 0;',
- 'this.li = 0;',
- 'this.ni = 0;',
- 'this.nu = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.d);',
- '$mod.DoIt($mod.dt);',
- '$mod.DoIt$1($mod.i);',
- '$mod.DoIt$1($mod.b);',
- '$mod.DoIt$1($mod.shi);',
- '$mod.DoIt$1($mod.w);',
- '$mod.DoIt$1($mod.smi);',
- '$mod.DoIt$1($mod.lw);',
- '$mod.DoIt$1($mod.li);',
- '$mod.DoIt$1($mod.ni);',
- '$mod.DoIt$1($mod.nu);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadNativeInt;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' int53 = nativeint;',
- ' tdatetime = double;',
- 'procedure DoIt(n: nativeint); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' d: double;',
- ' dt: tdatetime;',
- ' i: integer;',
- ' b: byte;',
- ' shi: shortint;',
- ' w: word;',
- ' smi: smallint;',
- ' lw: longword;',
- ' li: longint;',
- ' ni: nativeint;',
- ' nu: nativeuint;',
- 'begin',
- ' DoIt(d);',
- ' DoIt(dt);',
- ' DoIt(i);',
- ' DoIt(b);',
- ' DoIt(shi);',
- ' DoIt(w);',
- ' DoIt(smi);',
- ' DoIt(lw);',
- ' DoIt(li);',
- ' DoIt(ni);',
- ' DoIt(nu);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadNativeInt',
- LinesToStr([ // statements
- 'this.DoIt = function (n) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.d = 0.0;',
- 'this.dt = 0.0;',
- 'this.i = 0;',
- 'this.b = 0;',
- 'this.shi = 0;',
- 'this.w = 0;',
- 'this.smi = 0;',
- 'this.lw = 0;',
- 'this.li = 0;',
- 'this.ni = 0;',
- 'this.nu = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt$1($mod.d);',
- '$mod.DoIt$1($mod.dt);',
- '$mod.DoIt($mod.i);',
- '$mod.DoIt($mod.b);',
- '$mod.DoIt($mod.shi);',
- '$mod.DoIt($mod.w);',
- '$mod.DoIt($mod.smi);',
- '$mod.DoIt($mod.lw);',
- '$mod.DoIt($mod.li);',
- '$mod.DoIt($mod.ni);',
- '$mod.DoIt($mod.nu);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadWord;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' int53 = nativeint;',
- ' tdatetime = double;',
- 'procedure DoIt(w: word); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' d: double;',
- ' dt: tdatetime;',
- ' i: integer;',
- ' b: byte;',
- ' shi: shortint;',
- ' w: word;',
- ' smi: smallint;',
- ' lw: longword;',
- ' li: longint;',
- ' ni: nativeint;',
- ' nu: nativeuint;',
- 'begin',
- ' DoIt(d);',
- ' DoIt(dt);',
- ' DoIt(i);',
- ' DoIt(b);',
- ' DoIt(shi);',
- ' DoIt(w);',
- ' DoIt(smi);',
- ' DoIt(lw);',
- ' DoIt(li);',
- ' DoIt(ni);',
- ' DoIt(nu);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadWord',
- LinesToStr([ // statements
- 'this.DoIt = function (w) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.d = 0.0;',
- 'this.dt = 0.0;',
- 'this.i = 0;',
- 'this.b = 0;',
- 'this.shi = 0;',
- 'this.w = 0;',
- 'this.smi = 0;',
- 'this.lw = 0;',
- 'this.li = 0;',
- 'this.ni = 0;',
- 'this.nu = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt$1($mod.d);',
- '$mod.DoIt$1($mod.dt);',
- '$mod.DoIt$1($mod.i);',
- '$mod.DoIt($mod.b);',
- '$mod.DoIt($mod.shi);',
- '$mod.DoIt($mod.w);',
- '$mod.DoIt$1($mod.smi);',
- '$mod.DoIt$1($mod.lw);',
- '$mod.DoIt$1($mod.li);',
- '$mod.DoIt$1($mod.ni);',
- '$mod.DoIt$1($mod.nu);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadString;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' uni = string;',
- ' WChar = char;',
- 'procedure DoIt(s: string); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' s: string;',
- ' c: char;',
- ' u: uni;',
- 'begin',
- ' DoIt(s);',
- ' DoIt(c);',
- ' DoIt(u);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadString',
- LinesToStr([ // statements
- 'this.DoIt = function (s) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.s = "";',
- 'this.c = "";',
- 'this.u = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.s);',
- '$mod.DoIt($mod.c);',
- '$mod.DoIt($mod.u);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadChar;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' uni = string;',
- ' WChar = char;',
- 'procedure DoIt(c: char); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' s: string;',
- ' c: char;',
- ' u: uni;',
- 'begin',
- ' DoIt(s);',
- ' DoIt(c);',
- ' DoIt(u);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadChar',
- LinesToStr([ // statements
- 'this.DoIt = function (c) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.s = "";',
- 'this.c = "";',
- 'this.u = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt$1($mod.s);',
- '$mod.DoIt($mod.c);',
- '$mod.DoIt$1($mod.u);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadPointer;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- 'procedure DoIt(p: pointer); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' o: TObject;',
- 'begin',
- ' DoIt(o);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadPointer',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.DoIt = function (p) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.o);',
- '']));
- end;
- procedure TTestModule.TestJSValue_ForIn;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' v: JSValue;',
- ' key: string;',
- 'begin',
- ' for key in v do begin',
- ' if key=''abc'' then ;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_ForIn',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.key = "";',
- '']),
- LinesToStr([ // $mod.$main
- 'for ($mod.key in $mod.v) {',
- ' if ($mod.key === "abc") ;',
- '};',
- '']));
- end;
- procedure TTestModule.TestRTTI_IntRange;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TGraphicsColor = -$7FFFFFFF-1..$7FFFFFFF;',
- ' TColor = type TGraphicsColor;',
- 'var',
- ' p: TTypeInfo;',
- ' k: TTypeKind;',
- 'begin',
- ' p:=typeinfo(TGraphicsColor);',
- ' p:=typeinfo(TColor);',
- ' k:=GetTypeKind(TGraphicsColor);',
- ' k:=GetTypeKind(TColor);',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_IntRange',
- LinesToStr([ // statements
- 'this.$rtti.$Int("TGraphicsColor", {',
- ' minvalue: -2147483648,',
- ' maxvalue: 2147483647,',
- ' ordtype: 4',
- '});',
- 'this.$rtti.$inherited("TColor", this.$rtti["TGraphicsColor"], {});',
- 'this.p = null;',
- 'this.k = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TGraphicsColor"];',
- '$mod.p = $mod.$rtti["TColor"];',
- '$mod.k = 1;',
- '$mod.k = 1;',
- '']));
- end;
- procedure TTestModule.TestRTTI_Double;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TFloat = type double;',
- 'var',
- ' p: TTypeInfo;',
- 'begin',
- ' p:=typeinfo(double);',
- ' p:=typeinfo(TFloat);',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_Double',
- LinesToStr([ // statements
- 'this.$rtti.$inherited("TFloat", rtl.double, {});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = rtl.double;',
- '$mod.p = $mod.$rtti["TFloat"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_ProcType;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TProcA = procedure;');
- Add(' TMethodB = procedure of object;');
- Add(' TProcC = procedure; varargs;');
- Add(' TProcD = procedure(i: longint; const j: string; var c: char; out d: double);');
- Add(' TProcE = function: nativeint;');
- Add(' TProcF = function(const p: TProcA): nativeuint;');
- Add('var p: pointer;');
- Add('begin');
- Add(' p:=typeinfo(tproca);');
- ConvertProgram;
- CheckSource('TestRTTI_ProcType',
- LinesToStr([ // statements
- 'this.$rtti.$ProcVar("TProcA", {',
- ' procsig: rtl.newTIProcSig(null)',
- '});',
- 'this.$rtti.$MethodVar("TMethodB", {',
- ' procsig: rtl.newTIProcSig(null),',
- ' methodkind: 0',
- '});',
- 'this.$rtti.$ProcVar("TProcC", {',
- ' procsig: rtl.newTIProcSig(null, 2)',
- '});',
- 'this.$rtti.$ProcVar("TProcD", {',
- ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
- '});',
- 'this.$rtti.$ProcVar("TProcE", {',
- ' procsig: rtl.newTIProcSig(null, rtl.nativeint)',
- '});',
- 'this.$rtti.$ProcVar("TProcF", {',
- ' procsig: rtl.newTIProcSig([["p", this.$rtti["TProcA"], 2]], rtl.nativeuint)',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TProcA"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_ProcType_ArgFromOtherUnit;
- begin
- WithTypeInfo:=true;
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- 'type',
- ' TObject = class end;'
- ]),
- '');
- StartUnit(true);
- Add('interface');
- Add('uses unit2;');
- Add('type');
- Add(' TProcA = function(o: tobject): tobject;');
- Add('implementation');
- Add('type');
- Add(' TProcB = function(o: tobject): tobject;');
- Add('var p: Pointer;');
- Add('initialization');
- Add(' p:=typeinfo(tproca);');
- Add(' p:=typeinfo(tprocb);');
- ConvertUnit;
- CheckSource('TestRTTI_ProcType_ArgFromOtherUnit',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- 'this.$rtti.$ProcVar("TProcA", {',
- ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
- '});',
- '']),
- LinesToStr([ // this.$init
- '$impl.p = $mod.$rtti["TProcA"];',
- '$impl.p = $mod.$rtti["TProcB"];',
- '']),
- LinesToStr([ // implementation
- '$mod.$rtti.$ProcVar("TProcB", {',
- ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
- '});',
- '$impl.p = null;',
- '']) );
- end;
- procedure TTestModule.TestRTTI_EnumAndSetType;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TFlag = (light,dark);');
- Add(' TFlags = set of TFlag;');
- Add(' TProc = function(f: TFlags): TFlag;');
- Add('var p: pointer;');
- Add('begin');
- Add(' p:=typeinfo(tflag);');
- Add(' p:=typeinfo(tflags);');
- ConvertProgram;
- CheckSource('TestRTTI_EnumAndType',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "light",',
- ' light: 0,',
- ' "1": "dark",',
- ' dark: 1',
- '};',
- 'this.$rtti.$Enum("TFlag", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TFlag',
- '});',
- 'this.$rtti.$Set("TFlags", {',
- ' comptype: this.$rtti["TFlag"]',
- '});',
- 'this.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig([["f", this.$rtti["TFlags"]]], this.$rtti["TFlag"])',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TFlag"];',
- '$mod.p = $mod.$rtti["TFlags"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_EnumRange;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TCol = (red,green,blue);',
- ' TColRg = green..blue;',
- ' TSetOfColRg = set of TColRg;',
- 'var p: pointer;',
- 'begin',
- ' p:=typeinfo(tcolrg);',
- ' p:=typeinfo(tsetofcolrg);',
- '']);
- ConvertProgram;
- end;
- procedure TTestModule.TestRTTI_AnonymousEnumType;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TFlags = set of (red, green);');
- Add('var');
- Add(' f: TFlags;');
- Add('begin');
- Add(' Include(f,red);');
- ConvertProgram;
- CheckSource('TestRTTI_AnonymousEnumType',
- LinesToStr([ // statements
- 'this.TFlags$a = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "green",',
- ' green: 1',
- '};',
- 'this.$rtti.$Enum("TFlags$a", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TFlags$a',
- '});',
- 'this.$rtti.$Set("TFlags", {',
- ' comptype: this.$rtti["TFlags$a"]',
- '});',
- 'this.f = {};',
- '']),
- LinesToStr([
- '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
- '']));
- end;
- procedure TTestModule.TestRTTI_StaticArray;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TFlag = (light,dark);');
- Add(' TFlagNames = array[TFlag] of string;');
- Add(' TBoolNames = array[boolean] of string;');
- Add(' TByteArray = array[1..32768] of byte;');
- Add(' TProc = function(f: TBoolNames): TFlagNames;');
- Add('var p: pointer;');
- Add('begin');
- Add(' p:=typeinfo(TFlagNames);');
- Add(' p:=typeinfo(TBoolNames);');
- ConvertProgram;
- CheckSource('TestRTTI_StaticArray',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "light",',
- ' light: 0,',
- ' "1": "dark",',
- ' dark: 1',
- '};',
- 'this.$rtti.$Enum("TFlag", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TFlag',
- '});',
- 'this.$rtti.$StaticArray("TFlagNames", {',
- ' dims: [2],',
- ' eltype: rtl.string',
- '});',
- 'this.$rtti.$StaticArray("TBoolNames", {',
- ' dims: [2],',
- ' eltype: rtl.string',
- '});',
- 'this.$rtti.$StaticArray("TByteArray", {',
- ' dims: [32768],',
- ' eltype: rtl.byte',
- '});',
- 'this.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig([["f", this.$rtti["TBoolNames"]]], this.$rtti["TFlagNames"])',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TFlagNames"];',
- '$mod.p = $mod.$rtti["TBoolNames"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_DynArray;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TArrStr = array of string;');
- Add(' TArr2Dim = array of tarrstr;');
- Add(' TProc = function(f: TArrStr): TArr2Dim;');
- Add('var p: pointer;');
- Add('begin');
- Add(' p:=typeinfo(tarrstr);');
- Add(' p:=typeinfo(tarr2dim);');
- ConvertProgram;
- CheckSource('TestRTTI_DynArray',
- LinesToStr([ // statements
- 'this.$rtti.$DynArray("TArrStr", {',
- ' eltype: rtl.string',
- '});',
- 'this.$rtti.$DynArray("TArr2Dim", {',
- ' eltype: this.$rtti["TArrStr"]',
- '});',
- 'this.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig([["f", this.$rtti["TArrStr"]]], this.$rtti["TArr2Dim"])',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TArrStr"];',
- '$mod.p = $mod.$rtti["TArr2Dim"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TArr = array of array of longint;');
- Add('var a: TArr;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_ArrayNestedAnonymous',
- LinesToStr([ // statements
- 'this.$rtti.$DynArray("TArr$a", {',
- ' eltype: rtl.longint',
- '});',
- 'this.$rtti.$DynArray("TArr", {',
- ' eltype: this.$rtti["TArr$a"]',
- '});',
- 'this.a = [];',
- '']),
- LinesToStr([ // $mod.$main
- ]));
- end;
- procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' published');
- Add(' procedure Proc; virtual; abstract;');
- Add(' procedure Proc(Sender: tobject); virtual; abstract;');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError('Duplicate published method "Proc" at test1.pp(6,19)',
- nDuplicatePublishedMethodXAtY);
- ConvertProgram;
- end;
- procedure TTestModule.TestRTTI_PublishedMethodHideNoHint;
- begin
- WithTypeInfo:=true;
- StartUnit(false);
- Add([
- 'interface',
- 'type',
- ' TObject = class',
- ' end;',
- ' {$M+}',
- ' TBird = class',
- ' procedure Fly;',
- ' end;',
- ' {$M-}',
- 'type',
- ' TEagle = class(TBird)',
- ' procedure Fly;',
- ' end;',
- 'implementation',
- 'procedure TBird.Fly;',
- 'begin',
- 'end;',
- 'procedure TEagle.Fly;',
- 'begin',
- 'end;',
- '']);
- ConvertUnit;
- CheckSource('TestRTTI_PublishedMethodHideNoHint',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Fly = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("Fly", 0, null);',
- '});',
- 'rtl.createClass(this, "TEagle", this.TBird, function () {',
- ' this.Fly = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("Fly", 0, null);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- ]));
- CheckResolverUnexpectedHints(true);
- end;
- procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' published');
- Add(' procedure Proc; external name ''foo'';');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
- nPublishedNameMustMatchExternal);
- ConvertProgram;
- end;
- procedure TTestModule.TestRTTI_PublishedClassPropertyFail;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' class var FA: longint;');
- Add(' published');
- Add(' class property A: longint read FA;');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError('Invalid published property modifier "class"',
- nInvalidXModifierY);
- ConvertProgram;
- end;
- procedure TTestModule.TestRTTI_PublishedClassFieldFail;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' published');
- Add(' class var FA: longint;');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError(sSymbolCannotBePublished,
- nSymbolCannotBePublished);
- ConvertProgram;
- end;
- procedure TTestModule.TestRTTI_PublishedFieldExternalFail;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TObject = class');
- Add(' published');
- Add(' V: longint; external name ''foo'';');
- Add(' end;');
- Add('begin');
- SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
- nPublishedNameMustMatchExternal);
- ConvertProgram;
- end;
- procedure TTestModule.TestRTTI_Class_Field;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TObject = class');
- Add(' private');
- Add(' FPropA: string;');
- Add(' published');
- Add(' VarLI: longint;');
- Add(' VarC: char;');
- Add(' VarS: string;');
- Add(' VarD: double;');
- Add(' VarB: boolean;');
- Add(' VarLW: longword;');
- Add(' VarSmI: smallint;');
- Add(' VarW: word;');
- Add(' VarShI: shortint;');
- Add(' VarBy: byte;');
- Add(' VarExt: longint external name ''VarExt'';');
- Add(' ArrA, ArrB: array of byte;');
- Add(' end;');
- Add('var p: pointer;');
- Add(' Obj: tobject;');
- Add('begin');
- Add(' p:=typeinfo(tobject);');
- Add(' p:=typeinfo(p);');
- Add(' p:=typeinfo(obj);');
- ConvertProgram;
- CheckSource('TestRTTI_Class_Field',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FPropA = "";',
- ' this.VarLI = 0;',
- ' this.VarC = "";',
- ' this.VarS = "";',
- ' this.VarD = 0.0;',
- ' this.VarB = false;',
- ' this.VarLW = 0;',
- ' this.VarSmI = 0;',
- ' this.VarW = 0;',
- ' this.VarShI = 0;',
- ' this.VarBy = 0;',
- ' this.ArrA = [];',
- ' this.ArrB = [];',
- ' };',
- ' this.$final = function () {',
- ' this.ArrA = undefined;',
- ' this.ArrB = undefined;',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addField("VarLI", rtl.longint);',
- ' $r.addField("VarC", rtl.char);',
- ' $r.addField("VarS", rtl.string);',
- ' $r.addField("VarD", rtl.double);',
- ' $r.addField("VarB", rtl.boolean);',
- ' $r.addField("VarLW", rtl.longword);',
- ' $r.addField("VarSmI", rtl.smallint);',
- ' $r.addField("VarW", rtl.word);',
- ' $r.addField("VarShI", rtl.shortint);',
- ' $r.addField("VarBy", rtl.byte);',
- ' $r.addField("VarExt", rtl.longint);',
- ' $mod.$rtti.$DynArray("TObject.ArrB$a", {',
- ' eltype: rtl.byte',
- ' });',
- ' $r.addField("ArrA", $mod.$rtti["TObject.ArrB$a"]);',
- ' $r.addField("ArrB", $mod.$rtti["TObject.ArrB$a"]);',
- '});',
- 'this.p = null;',
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TObject"];',
- '$mod.p = rtl.pointer;',
- '$mod.p = $mod.Obj.$rtti;',
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_Method;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' private');
- Add(' procedure Internal; external name ''$intern'';');
- Add(' published');
- Add(' procedure Click; virtual; abstract;');
- Add(' procedure Notify(Sender: TObject); virtual; abstract;');
- Add(' function GetNotify: boolean; external name ''GetNotify'';');
- Add(' procedure Println(a,b: longint); varargs; virtual; abstract;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_Method',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("Click", 0, null);',
- ' $r.addMethod("Notify", 0, [["Sender", $r]]);',
- ' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});',
- ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {',
- ' flags: 2',
- ' });',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_MethodArgFlags;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' published');
- Add(' procedure OpenArray(const Args: array of string); virtual; abstract;');
- Add(' procedure ByRef(var Value: longint; out Item: longint); virtual; abstract;');
- Add(' procedure Untyped(var Value; out Item); virtual; abstract;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_MethodOpenArray',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- '$r.addMethod("OpenArray", 0, [["Args", rtl.string, 10]]);',
- '$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]]);',
- '$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]]);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_Property;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TObject = class');
- Add(' private');
- Add(' FColor: longint;');
- Add(' FColorStored: boolean;');
- Add(' procedure SetColor(Value: longint); virtual; abstract;');
- Add(' function GetColor: longint; virtual; abstract;');
- Add(' function GetColorStored: boolean; virtual; abstract;');
- Add(' FExtSize: longint external name ''$extSize'';');
- Add(' FExtSizeStored: boolean external name ''$extSizeStored'';');
- Add(' procedure SetExtSize(Value: longint); external name ''$setSize'';');
- Add(' function GetExtSize: longint; external name ''$getSize'';');
- Add(' function GetExtSizeStored: boolean; external name ''$getExtSizeStored'';');
- Add(' published');
- Add(' property ColorA: longint read FColor;');
- Add(' property ColorB: longint write FColor;');
- Add(' property ColorC: longint read GetColor write SetColor;');
- Add(' property ColorD: longint read FColor write FColor stored FColorStored;');
- Add(' property ExtSizeA: longint read FExtSize write FExtSize;');
- Add(' property ExtSizeB: longint read GetExtSize write SetExtSize stored FExtSizeStored;');
- Add(' property ExtSizeC: longint read FExtSize write FExtSize stored GetExtSizeStored;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_Property',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FColor = 0;',
- ' this.FColorStored = false;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty("ColorA", 0, rtl.longint, "FColor", "");',
- ' $r.addProperty("ColorB", 0, rtl.longint, "", "FColor");',
- ' $r.addProperty("ColorC", 3, rtl.longint, "GetColor", "SetColor");',
- ' $r.addProperty(',
- ' "ColorD",',
- ' 8,',
- ' rtl.longint,',
- ' "FColor",',
- ' "FColor",',
- ' {',
- ' stored: "FColorStored"',
- ' }',
- ' );',
- ' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
- ' $r.addProperty(',
- ' "ExtSizeB",',
- ' 11,',
- ' rtl.longint,',
- ' "$getSize",',
- ' "$setSize",',
- ' {',
- ' stored: "$extSizeStored"',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "ExtSizeC",',
- ' 12,',
- ' rtl.longint,',
- ' "$extSize",',
- ' "$extSize",',
- ' {',
- ' stored: "$getExtSizeStored"',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_PropertyParams;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' integer = longint;');
- Add(' TObject = class');
- Add(' private');
- Add(' function GetItems(i: integer): tobject; virtual; abstract;');
- Add(' procedure SetItems(i: integer; value: tobject); virtual; abstract;');
- Add(' function GetValues(const i: integer; var b: boolean): char; virtual; abstract;');
- Add(' procedure SetValues(const i: integer; var b: boolean; value: char); virtual; abstract;');
- Add(' published');
- Add(' property Items[Index: integer]: tobject read getitems write setitems;');
- Add(' property Values[const keya: integer; var keyb: boolean]: char read getvalues write setvalues;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_PropertyParams',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty("Items", 3, $r, "GetItems", "SetItems");',
- ' $r.addProperty("Values", 3, rtl.char, "GetValues", "SetValues");',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_OtherUnit_TypeAlias;
- begin
- WithTypeInfo:=true;
- AddModuleWithIntfImplSrc('unit1.pas',
- 'type TColor = -5..5;',
- '');
- StartProgram(true);
- Add([
- 'uses unit1;',
- 'type',
- ' TColorAlias = TColor;',
- ' TColorTypeAlias = type TColor;',
- ' TObject = class',
- ' private',
- ' fColor: TColor;',
- ' fAlias: TColorAlias;',
- ' fTypeAlias: TColorTypeAlias;',
- ' published',
- ' property Color: TColor read fcolor;',
- ' property Alias: TColorAlias read falias;',
- ' property TypeAlias: TColorTypeAlias read ftypealias;',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_Class_OtherUnit_TypeAlias',
- LinesToStr([ // statements
- 'this.$rtti.$inherited("TColorTypeAlias", pas.unit1.$rtti["TColor"], {});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.fColor = 0;',
- ' this.fAlias = 0;',
- ' this.fTypeAlias = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty("Color", 0, pas.unit1.$rtti["TColor"], "fColor", "");',
- ' $r.addProperty("Alias", 0, pas.unit1.$rtti["TColor"], "fAlias", "");',
- ' $r.addProperty("TypeAlias", 0, $mod.$rtti["TColorTypeAlias"], "fTypeAlias", "");',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_OmitRTTI;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- '{$modeswitch omitrtti}',
- 'type',
- ' TObject = class',
- ' private',
- ' FA: byte;',
- ' published',
- ' property A: byte read FA write FA;',
- ' end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_Class_OmitRTTI',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FA = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_Field_AnonymousArrayOfSelfClass;
- begin
- WithTypeInfo:=true;
- StartUnit(true,[supTObject]);
- Add([
- 'interface',
- 'type',
- ' {$M+1}',
- ' TBird = class',
- ' published',
- ' Swarm: array of TBird;',
- ' end;',
- 'implementation',
- '']);
- ConvertUnit;
- CheckSource('TestRTTI_Class_Field_AnonymousArrayOfSelfClass',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TBird", pas.system.TObject, function () {',
- ' this.$init = function () {',
- ' pas.system.TObject.$init.call(this);',
- ' this.Swarm = [];',
- ' };',
- ' this.$final = function () {',
- ' this.Swarm = undefined;',
- ' pas.system.TObject.$final.call(this);',
- ' };',
- ' var $r = this.$rtti;',
- ' $mod.$rtti.$DynArray("TBird.Swarm$a", {',
- ' eltype: $r',
- ' });',
- ' $r.addField("Swarm", $mod.$rtti["TBird.Swarm$a"]);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_IndexModifier;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (red, blue);',
- ' TObject = class',
- ' FB: boolean;',
- ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
- ' function GetBoolBool(Index: boolean): boolean; virtual; abstract;',
- ' procedure SetBoolBool(Index: boolean; b: boolean); virtual; abstract;',
- ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
- ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
- ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
- ' published',
- ' property B1: boolean index 1 read FB write SetIntBool;',
- ' property B2: boolean index TEnum.blue read GetEnumBool write FB;',
- ' property I1[A: String]: boolean index 2 read GetStrIntBool write SetStrIntBool;',
- ' end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_IndexModifier',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'this.$rtti.$Enum("TEnum", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TEnum',
- '});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FB = false;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "B1",',
- ' 18,',
- ' rtl.boolean,',
- ' "FB",',
- ' "SetIntBool",',
- ' {',
- ' index: 1',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B2",',
- ' 17,',
- ' rtl.boolean,',
- ' "GetEnumBool",',
- ' "FB",',
- ' {',
- ' index: $mod.TEnum.blue',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I1",',
- ' 19,',
- ' rtl.boolean,',
- ' "GetStrIntBool",',
- ' "SetStrIntBool",',
- ' {',
- ' index: 2',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_StoredModifier;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'const',
- ' ConstB = true;',
- 'type',
- ' TObject = class',
- ' private',
- ' FB: boolean;',
- ' function IsBStored: boolean; virtual; abstract;',
- ' published',
- ' property BoolA: boolean read FB stored true;',
- ' property BoolB: boolean read FB stored false;',
- ' property BoolC: boolean read FB stored FB;',
- ' property BoolD: boolean read FB stored ConstB;',
- ' property BoolE: boolean read FB stored IsBStored;',
- ' end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_StoredModifier',
- LinesToStr([ // statements
- 'this.ConstB = true;',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FB = false;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty("BoolA", 0, rtl.boolean, "FB", "");',
- ' $r.addProperty("BoolB", 4, rtl.boolean, "FB", "");',
- ' $r.addProperty(',
- ' "BoolC",',
- ' 8,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' stored: "FB"',
- ' }',
- ' );',
- ' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
- ' $r.addProperty(',
- ' "BoolE",',
- ' 12,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' stored: "IsBStored"',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_DefaultValue;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (red, blue);',
- 'const',
- ' CB = true or false;',
- ' CI = 1+2;',
- 'type',
- ' TObject = class',
- ' FB: boolean;',
- ' FI: longint;',
- ' FE: TEnum;',
- ' published',
- ' property B1: boolean read FB default true;',
- ' property B2: boolean read FB default CB;',
- ' property B3: boolean read FB default test1.cb;',
- ' property I1: longint read FI default 2;',
- ' property I2: longint read FI default CI;',
- ' property E1: TEnum read FE default red;',
- ' property E2: TEnum read FE default TEnum.blue;',
- ' end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_DefaultValue',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'this.$rtti.$Enum("TEnum", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TEnum',
- '});',
- 'this.CB = true || false;',
- 'this.CI = 1 + 2;',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FB = false;',
- ' this.FI = 0;',
- ' this.FE = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "B1",',
- ' 0,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B2",',
- ' 0,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B3",',
- ' 0,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I1",',
- ' 0,',
- ' rtl.longint,',
- ' "FI",',
- ' "",',
- ' {',
- ' Default: 2',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I2",',
- ' 0,',
- ' rtl.longint,',
- ' "FI",',
- ' "",',
- ' {',
- ' Default: 3',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "E1",',
- ' 0,',
- ' $mod.$rtti["TEnum"],',
- ' "FE",',
- ' "",',
- ' {',
- ' Default: $mod.TEnum.red',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "E2",',
- ' 0,',
- ' $mod.$rtti["TEnum"],',
- ' "FE",',
- ' "",',
- ' {',
- ' Default: $mod.TEnum.blue',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_DefaultValueSet;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TEnum = (red, blue);',
- ' TSet = set of TEnum;',
- 'const',
- ' CSet = [red,blue];',
- 'type',
- ' TObject = class',
- ' FSet: TSet;',
- ' published',
- ' property Set1: TSet read FSet default [];',
- ' property Set2: TSet read FSet default [red];',
- ' property Set3: TSet read FSet default [red,blue];',
- ' property Set4: TSet read FSet default CSet;',
- ' end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_DefaultValueSet',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "blue",',
- ' blue: 1',
- '};',
- 'this.$rtti.$Enum("TEnum", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TEnum',
- '});',
- 'this.$rtti.$Set("TSet", {',
- ' comptype: this.$rtti["TEnum"]',
- '});',
- 'this.CSet = rtl.createSet(this.TEnum.red, this.TEnum.blue);',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FSet = {};',
- ' };',
- ' this.$final = function () {',
- ' this.FSet = undefined;',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "Set1",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' {',
- ' Default: {}',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set2",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' {',
- ' Default: rtl.createSet($mod.TEnum.red)',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set3",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' {',
- ' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set4",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' {',
- ' Default: $mod.CSet',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_DefaultValueRangeType;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TRg = -1..1;',
- 'const',
- ' l = low(TRg);',
- ' h = high(TRg);',
- 'type',
- ' TObject = class',
- ' FV: TRg;',
- ' published',
- ' property V1: TRg read FV default -1;',
- ' end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_DefaultValueRangeType',
- LinesToStr([ // statements
- 'this.$rtti.$Int("TRg", {',
- ' minvalue: -1,',
- ' maxvalue: 1,',
- ' ordtype: 0',
- '});',
- 'this.l = -1;',
- 'this.h = 1;',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FV = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "V1",',
- ' 0,',
- ' $mod.$rtti["TRg"],',
- ' "FV",',
- ' "",',
- ' {',
- ' Default: -1',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_DefaultValueInherit;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' FA, FB: byte;',
- ' property A: byte read FA default 1;',
- ' property B: byte read FB default 2;',
- ' end;',
- ' TBird = class',
- ' published',
- ' property A;',
- ' property B nodefault;',
- ' end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_DefaultValueInherit',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FA = 0;',
- ' this.FB = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "A",',
- ' 0,',
- ' rtl.byte,',
- ' "FA",',
- ' "",',
- ' {',
- ' Default: 1',
- ' }',
- ' );',
- ' $r.addProperty("B", 0, rtl.byte, "FB", "");',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_OverrideMethod;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' published');
- Add(' procedure DoIt; virtual; abstract;');
- Add(' end;');
- Add(' TSky = class');
- Add(' published');
- Add(' procedure DoIt; override;');
- Add(' end;');
- Add('procedure TSky.DoIt; begin end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_OverrideMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("DoIt", 0, null);',
- '});',
- 'rtl.createClass(this, "TSky", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_ReintroduceMethod;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' published',
- ' procedure DoIt;',
- ' end;',
- ' TSky = class',
- ' published',
- ' procedure DoIt; reintroduce;',
- ' end;',
- 'procedure TObject.DoIt; begin end;',
- 'procedure TSky.DoIt;',
- 'begin',
- ' inherited DoIt;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_ReintroduceMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("DoIt", 0, null);',
- '});',
- 'rtl.createClass(this, "TSky", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' $mod.TObject.DoIt.call(this);',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("DoIt", 0, null);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_OverloadProperty;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' protected');
- Add(' FFlag: longint;');
- Add(' published');
- Add(' property Flag: longint read fflag;');
- Add(' end;');
- Add(' TSky = class');
- Add(' published');
- Add(' property FLAG: longint write fflag;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_OverrideMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FFlag = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty("Flag", 0, rtl.longint, "FFlag", "");',
- '});',
- 'rtl.createClass(this, "TSky", this.TObject, function () {',
- ' var $r = this.$rtti;',
- ' $r.addProperty("Flag", 0, rtl.longint, "", "FFlag");',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_ClassForward;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TObject = class end;');
- Add(' tbridge = class;');
- Add(' TProc = function: tbridge;');
- Add(' TOger = class');
- Add(' published');
- Add(' FBridge: tbridge;');
- Add(' procedure SetBridge(Value: tbridge); virtual; abstract;');
- Add(' property Bridge: tbridge read fbridge write setbridge;');
- Add(' end;');
- Add(' TBridge = class');
- Add(' FOger: toger;');
- Add(' end;');
- Add('var p: Pointer;');
- Add(' b: tbridge;');
- Add('begin');
- Add(' p:=typeinfo(tbridge);');
- Add(' p:=typeinfo(b);');
- ConvertProgram;
- CheckSource('TestRTTI_ClassForward',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.$rtti.$Class("TBridge");',
- 'this.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig(null, this.$rtti["TBridge"])',
- '});',
- 'rtl.createClass(this, "TOger", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FBridge = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FBridge = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addField("FBridge", $mod.$rtti["TBridge"]);',
- ' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]]);',
- ' $r.addProperty("Bridge", 2, $mod.$rtti["TBridge"], "FBridge", "SetBridge");',
- '});',
- 'rtl.createClass(this, "TBridge", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FOger = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FOger = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- '});',
- 'this.p = null;',
- 'this.b = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TBridge"];',
- '$mod.p = $mod.b.$rtti;',
- '']));
- end;
- procedure TTestModule.TestRTTI_ClassOf;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TClass = class of tobject;');
- Add(' TProcA = function: TClass;');
- Add(' TObject = class');
- Add(' published');
- Add(' C: tclass;');
- Add(' end;');
- Add(' tfox = class;');
- Add(' TBird = class end;');
- Add(' TBirds = class of tbird;');
- Add(' TFox = class end;');
- Add(' TFoxes = class of tfox;');
- Add(' TCows = class of TCow;');
- Add(' TCow = class;');
- Add(' TCow = class end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_ClassOf',
- LinesToStr([ // statements
- 'this.$rtti.$Class("TObject");',
- 'this.$rtti.$ClassRef("TClass", {',
- ' instancetype: this.$rtti["TObject"]',
- '});',
- 'this.$rtti.$ProcVar("TProcA", {',
- ' procsig: rtl.newTIProcSig(null, this.$rtti["TClass"])',
- '});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.C = null;',
- ' };',
- ' this.$final = function () {',
- ' this.C = undefined;',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addField("C", $mod.$rtti["TClass"]);',
- '});',
- 'this.$rtti.$Class("TFox");',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- '});',
- 'this.$rtti.$ClassRef("TBirds", {',
- ' instancetype: this.$rtti["TBird"]',
- '});',
- 'rtl.createClass(this, "TFox", this.TObject, function () {',
- '});',
- 'this.$rtti.$ClassRef("TFoxes", {',
- ' instancetype: this.$rtti["TFox"]',
- '});',
- 'this.$rtti.$Class("TCow");',
- 'this.$rtti.$ClassRef("TCows", {',
- ' instancetype: this.$rtti["TCow"]',
- '});',
- 'rtl.createClass(this, "TCow", this.TObject, function () {',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Record;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TPoint = record');
- Add(' x,y: integer;');
- Add(' end;');
- Add('var p: pointer;');
- Add(' r: tpoint;');
- Add('begin');
- Add(' p:=typeinfo(tpoint);');
- Add(' p:=typeinfo(r);');
- Add(' p:=typeinfo(r.x);');
- ConvertProgram;
- CheckSource('TestRTTI_Record',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- ' var $r = $mod.$rtti.$Record("TPoint", {});',
- ' $r.addField("x", rtl.longint);',
- ' $r.addField("y", rtl.longint);',
- '});',
- 'this.p = null;',
- 'this.r = this.TPoint.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TPoint"];',
- '$mod.p = $mod.$rtti["TPoint"];',
- '$mod.p = rtl.longint;',
- '']));
- end;
- procedure TTestModule.TestRTTI_RecordAnonymousArray;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add(' TFloatRec = record');
- Add(' c,d: array of char;');
- // Add(' i: array of array of longint;');
- Add(' end;');
- Add('var p: pointer;');
- Add(' r: tfloatrec;');
- Add('begin');
- Add(' p:=typeinfo(tfloatrec);');
- Add(' p:=typeinfo(r);');
- Add(' p:=typeinfo(r.d);');
- ConvertProgram;
- CheckSource('TestRTTI_Record',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TFloatRec", function () {',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.c = [];',
- ' r.d = [];',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.c === b.c) && (this.d === b.d);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.c = rtl.arrayRef(s.c);',
- ' this.d = rtl.arrayRef(s.d);',
- ' return this;',
- ' };',
- ' var $r = $mod.$rtti.$Record("TFloatRec", {});',
- ' $mod.$rtti.$DynArray("TFloatRec.d$a", {',
- ' eltype: rtl.char',
- ' });',
- ' $r.addField("c", $mod.$rtti["TFloatRec.d$a"]);',
- ' $r.addField("d", $mod.$rtti["TFloatRec.d$a"]);',
- '});',
- 'this.p = null;',
- 'this.r = this.TFloatRec.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TFloatRec"];',
- '$mod.p = $mod.$rtti["TFloatRec"];',
- '$mod.p = $mod.$rtti["TFloatRec.d$a"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_Record_ClassVarType;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- '{$modeswitch AdvancedRecords}',
- 'type',
- ' TPoint = record',
- ' type TProc = procedure(w: word);',
- ' class var p: TProc;',
- ' end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_Record_ClassVarType',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TPoint", function () {',
- ' $mod.$rtti.$ProcVar("TPoint.TProc", {',
- ' procsig: rtl.newTIProcSig([["w", rtl.word]])',
- ' });',
- ' this.p = null;',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' var $r = $mod.$rtti.$Record("TPoint", {});',
- ' $r.addField("p", $mod.$rtti["TPoint.TProc"]);',
- '}, true);',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_LocalTypes;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'procedure DoIt;',
- 'type',
- ' integer = longint;',
- ' TPoint = record',
- ' x,y: integer;',
- ' end;',
- 'var p: TPoint;',
- 'begin',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRTTI_LocalTypes',
- LinesToStr([ // statements
- 'var TPoint = rtl.recNewT(null, "", function () {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' this.$eq = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' return this;',
- ' };',
- '});',
- 'this.DoIt = function () {',
- ' var p = TPoint.$new();',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_BaseTypes;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TCaption = string;',
- ' TYesNo = boolean;',
- ' TLetter = char;',
- ' TFloat = double;',
- ' TPtr = pointer;',
- ' TShortInt = shortint;',
- ' TByte = byte;',
- ' TSmallInt = smallint;',
- ' TWord = word;',
- ' TInt32 = longint;',
- ' TDWord = longword;',
- ' TValue = jsvalue;',
- 'var p: TPtr;',
- 'begin',
- ' p:=typeinfo(string);',
- ' p:=typeinfo(tcaption);',
- ' p:=typeinfo(boolean);',
- ' p:=typeinfo(tyesno);',
- ' p:=typeinfo(char);',
- ' p:=typeinfo(tletter);',
- ' p:=typeinfo(double);',
- ' p:=typeinfo(tfloat);',
- ' p:=typeinfo(pointer);',
- ' p:=typeinfo(tptr);',
- ' p:=typeinfo(shortint);',
- ' p:=typeinfo(tshortint);',
- ' p:=typeinfo(byte);',
- ' p:=typeinfo(tbyte);',
- ' p:=typeinfo(smallint);',
- ' p:=typeinfo(tsmallint);',
- ' p:=typeinfo(word);',
- ' p:=typeinfo(tword);',
- ' p:=typeinfo(longword);',
- ' p:=typeinfo(tdword);',
- ' p:=typeinfo(jsvalue);',
- ' p:=typeinfo(tvalue);',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_TypeInfo_BaseTypes',
- LinesToStr([ // statements
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = rtl.string;',
- '$mod.p = rtl.string;',
- '$mod.p = rtl.boolean;',
- '$mod.p = rtl.boolean;',
- '$mod.p = rtl.char;',
- '$mod.p = rtl.char;',
- '$mod.p = rtl.double;',
- '$mod.p = rtl.double;',
- '$mod.p = rtl.pointer;',
- '$mod.p = rtl.pointer;',
- '$mod.p = rtl.shortint;',
- '$mod.p = rtl.shortint;',
- '$mod.p = rtl.byte;',
- '$mod.p = rtl.byte;',
- '$mod.p = rtl.smallint;',
- '$mod.p = rtl.smallint;',
- '$mod.p = rtl.word;',
- '$mod.p = rtl.word;',
- '$mod.p = rtl.longword;',
- '$mod.p = rtl.longword;',
- '$mod.p = rtl.jsvalue;',
- '$mod.p = rtl.jsvalue;',
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_Type_BaseTypes;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TCaption = type string;',
- ' TYesNo = type boolean;',
- ' TLetter = type char;',
- ' TFloat = type double;',
- ' TPtr = type pointer;',
- ' TShortInt = type shortint;',
- ' TByte = type byte;',
- ' TSmallInt = type smallint;',
- ' TWord = type word;',
- ' TInt32 = type longint;',
- ' TDWord = type longword;',
- ' TValue = type jsvalue;',
- ' TAliasValue = type TValue;',
- 'var',
- ' p: TPtr;',
- ' a: TAliasValue;',
- 'begin',
- ' p:=typeinfo(tcaption);',
- ' p:=typeinfo(tyesno);',
- ' p:=typeinfo(tletter);',
- ' p:=typeinfo(tfloat);',
- ' p:=typeinfo(tptr);',
- ' p:=typeinfo(tshortint);',
- ' p:=typeinfo(tbyte);',
- ' p:=typeinfo(tsmallint);',
- ' p:=typeinfo(tword);',
- ' p:=typeinfo(tdword);',
- ' p:=typeinfo(tvalue);',
- ' p:=typeinfo(taliasvalue);',
- ' p:=typeinfo(a);',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_TypeInfo_Type_BaseTypes',
- LinesToStr([ // statements
- 'this.$rtti.$inherited("TCaption", rtl.string, {});',
- 'this.$rtti.$inherited("TYesNo", rtl.boolean, {});',
- 'this.$rtti.$inherited("TLetter", rtl.char, {});',
- 'this.$rtti.$inherited("TFloat", rtl.double, {});',
- 'this.$rtti.$inherited("TPtr", rtl.pointer, {});',
- 'this.$rtti.$inherited("TShortInt", rtl.shortint, {});',
- 'this.$rtti.$inherited("TByte", rtl.byte, {});',
- 'this.$rtti.$inherited("TSmallInt", rtl.smallint, {});',
- 'this.$rtti.$inherited("TWord", rtl.word, {});',
- 'this.$rtti.$inherited("TInt32", rtl.longint, {});',
- 'this.$rtti.$inherited("TDWord", rtl.longword, {});',
- 'this.$rtti.$inherited("TValue", rtl.jsvalue, {});',
- 'this.$rtti.$inherited("TAliasValue", this.$rtti["TValue"], {});',
- 'this.p = null;',
- 'this.a = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TCaption"];',
- '$mod.p = $mod.$rtti["TYesNo"];',
- '$mod.p = $mod.$rtti["TLetter"];',
- '$mod.p = $mod.$rtti["TFloat"];',
- '$mod.p = $mod.$rtti["TPtr"];',
- '$mod.p = $mod.$rtti["TShortInt"];',
- '$mod.p = $mod.$rtti["TByte"];',
- '$mod.p = $mod.$rtti["TSmallInt"];',
- '$mod.p = $mod.$rtti["TWord"];',
- '$mod.p = $mod.$rtti["TDWord"];',
- '$mod.p = $mod.$rtti["TValue"];',
- '$mod.p = $mod.$rtti["TAliasValue"];',
- '$mod.p = $mod.$rtti["TAliasValue"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_LocalFail;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('procedure DoIt;');
- Add('type');
- Add(' integer = longint;');
- Add(' TPoint = record');
- Add(' x,y: integer;');
- Add(' end;');
- Add('var p: pointer;');
- Add('begin');
- Add(' p:=typeinfo(tpoint);');
- Add('end;');
- Add('begin');
- SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
- ConvertProgram;
- end;
- procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TFlag = (up,down);',
- ' TFlags = set of TFlag;',
- 'var',
- ' ti: TTypeInfo;',
- ' tiInt: TTypeInfoInteger;',
- ' tiEnum: TTypeInfoEnum;',
- ' tiSet: TTypeInfoSet;',
- 'begin',
- ' ti:=typeinfo(string);',
- ' ti:=typeinfo(boolean);',
- ' ti:=typeinfo(char);',
- ' ti:=typeinfo(double);',
- ' tiInt:=typeinfo(shortint);',
- ' tiInt:=typeinfo(byte);',
- ' tiInt:=typeinfo(smallint);',
- ' tiInt:=typeinfo(word);',
- ' tiInt:=typeinfo(longint);',
- ' tiInt:=typeinfo(longword);',
- ' ti:=typeinfo(jsvalue);',
- ' tiEnum:=typeinfo(tflag);',
- ' tiSet:=typeinfo(tflags);']);
- ConvertProgram;
- CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "up",',
- ' up: 0,',
- ' "1": "down",',
- ' down: 1',
- '};',
- 'this.$rtti.$Enum("TFlag", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TFlag',
- '});',
- 'this.$rtti.$Set("TFlags", {',
- ' comptype: this.$rtti["TFlag"]',
- '});',
- 'this.ti = null;',
- 'this.tiInt = null;',
- 'this.tiEnum = null;',
- 'this.tiSet = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ti = rtl.string;',
- '$mod.ti = rtl.boolean;',
- '$mod.ti = rtl.char;',
- '$mod.ti = rtl.double;',
- '$mod.tiInt = rtl.shortint;',
- '$mod.tiInt = rtl.byte;',
- '$mod.tiInt = rtl.smallint;',
- '$mod.tiInt = rtl.word;',
- '$mod.tiInt = rtl.longint;',
- '$mod.tiInt = rtl.longword;',
- '$mod.ti = rtl.jsvalue;',
- '$mod.tiEnum = $mod.$rtti["TFlag"];',
- '$mod.tiSet = $mod.$rtti["TFlags"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses2;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TStaticArr = array[boolean] of string;');
- Add(' TDynArr = array of string;');
- Add(' TProc = procedure;');
- Add(' TMethod = procedure of object;');
- Add('var');
- Add(' StaticArray: TStaticArr;');
- Add(' tiStaticArray: TTypeInfoStaticArray;');
- Add(' DynArray: TDynArr;');
- Add(' tiDynArray: TTypeInfoDynArray;');
- Add(' ProcVar: TProc;');
- Add(' tiProcVar: TTypeInfoProcVar;');
- Add(' MethodVar: TMethod;');
- Add(' tiMethodVar: TTypeInfoMethodVar;');
- Add('begin');
- Add(' tiStaticArray:=typeinfo(StaticArray);');
- Add(' tiStaticArray:=typeinfo(TStaticArr);');
- Add(' tiDynArray:=typeinfo(DynArray);');
- Add(' tiDynArray:=typeinfo(TDynArr);');
- Add(' tiProcVar:=typeinfo(ProcVar);');
- Add(' tiProcVar:=typeinfo(TProc);');
- Add(' tiMethodVar:=typeinfo(MethodVar);');
- Add(' tiMethodVar:=typeinfo(TMethod);');
- ConvertProgram;
- CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses2',
- LinesToStr([ // statements
- 'this.$rtti.$StaticArray("TStaticArr", {',
- ' dims: [2],',
- ' eltype: rtl.string',
- '});',
- 'this.$rtti.$DynArray("TDynArr", {',
- ' eltype: rtl.string',
- '});',
- 'this.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig(null)',
- '});',
- 'this.$rtti.$MethodVar("TMethod", {',
- ' procsig: rtl.newTIProcSig(null),',
- ' methodkind: 0',
- '});',
- 'this.StaticArray = rtl.arraySetLength(null,"",2);',
- 'this.tiStaticArray = null;',
- 'this.DynArray = [];',
- 'this.tiDynArray = null;',
- 'this.ProcVar = null;',
- 'this.tiProcVar = null;',
- 'this.MethodVar = null;',
- 'this.tiMethodVar = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
- '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
- '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
- '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
- '$mod.tiProcVar = $mod.$rtti["TProc"];',
- '$mod.tiProcVar = $mod.$rtti["TProc"];',
- '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
- '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TRec = record end;');
- // ToDo: ^TRec
- Add(' TObject = class end;');
- Add(' TClass = class of tobject;');
- Add('var');
- Add(' Rec: trec;');
- Add(' tiRecord: ttypeinforecord;');
- Add(' Obj: tobject;');
- Add(' tiClass: ttypeinfoclass;');
- Add(' aClass: tclass;');
- Add(' tiClassRef: ttypeinfoclassref;');
- // ToDo: ^TRec
- Add(' tiPointer: ttypeinfopointer;');
- Add('begin');
- Add(' tirecord:=typeinfo(trec);');
- Add(' tirecord:=typeinfo(trec);');
- Add(' ticlass:=typeinfo(obj);');
- Add(' ticlass:=typeinfo(tobject);');
- Add(' ticlass:=typeinfo(aclass);');
- Add(' ticlassref:=typeinfo(tclass);');
- ConvertProgram;
- CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses3',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' $mod.$rtti.$Record("TRec", {});',
- '});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.$rtti.$ClassRef("TClass", {',
- ' instancetype: this.$rtti["TObject"]',
- '});',
- 'this.Rec = this.TRec.$new();',
- 'this.tiRecord = null;',
- 'this.Obj = null;',
- 'this.tiClass = null;',
- 'this.aClass = null;',
- 'this.tiClassRef = null;',
- 'this.tiPointer = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.tiRecord = $mod.$rtti["TRec"];',
- '$mod.tiRecord = $mod.$rtti["TRec"];',
- '$mod.tiClass = $mod.Obj.$rtti;',
- '$mod.tiClass = $mod.$rtti["TObject"];',
- '$mod.tiClass = $mod.aClass.$rtti;',
- '$mod.tiClassRef = $mod.$rtti["TClass"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_FunctionClassType;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TClass = class of tobject;',
- ' TObject = class',
- ' function MyClass: TClass;',
- ' class function ClassType: TClass;',
- ' end;',
- 'function TObject.MyClass: TClass;',
- 'var t: TTypeInfoClass;',
- 'begin',
- ' t:=TypeInfo(Self);',
- ' t:=TypeInfo(Result);',
- ' t:=TypeInfo(TObject);',
- 'end;',
- 'class function TObject.ClassType: TClass;',
- 'var t: TTypeInfoClass;',
- 'begin',
- ' t:=TypeInfo(Self);',
- ' t:=TypeInfo(Result);',
- 'end;',
- 'var',
- ' Obj: TObject;',
- ' t: TTypeInfoClass;',
- 'begin',
- ' t:=TypeInfo(TObject.ClassType);',
- ' t:=TypeInfo(Obj.ClassType);',
- ' t:=TypeInfo(Obj.MyClass);',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_TypeInfo_FunctionClassType',
- LinesToStr([ // statements
- 'this.$rtti.$Class("TObject");',
- 'this.$rtti.$ClassRef("TClass", {',
- ' instancetype: this.$rtti["TObject"]',
- '});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.MyClass = function () {',
- ' var Result = null;',
- ' var t = null;',
- ' t = this.$rtti;',
- ' t = Result.$rtti;',
- ' t = $mod.$rtti["TObject"];',
- ' return Result;',
- ' };',
- ' this.ClassType = function () {',
- ' var Result = null;',
- ' var t = null;',
- ' t = this.$rtti;',
- ' t = Result.$rtti;',
- ' return Result;',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.t = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.t = $mod.TObject.ClassType().$rtti;',
- '$mod.t = $mod.Obj.$class.ClassType().$rtti;',
- '$mod.t = $mod.Obj.MyClass().$rtti;',
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
- begin
- WithTypeInfo:=true;
- AddModuleWithIntfImplSrc('typinfo.pas',
- LinesToStr([
- '{$modeswitch externalclass}',
- 'type',
- ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
- ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
- '']),
- '');
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- 'uses typinfo;',
- 'type PTypeInfo = TTypeInfo;', // delphi compatibility code
- 'procedure DoPtr(p: PTypeInfo);',
- 'procedure DoInfo(t: TTypeInfo);',
- 'procedure DoInt(t: TTypeInfoInteger);',
- '']),
- LinesToStr([
- 'procedure DoPtr(p: PTypeInfo);',
- 'begin end;',
- 'procedure DoInfo(t: TTypeInfo);',
- 'begin end;',
- 'procedure DoInt(t: TTypeInfoInteger);',
- 'begin end;',
- '']));
- StartUnit(true);
- Add([
- 'interface',
- 'uses unit2;', // does not use unit typinfo
- 'implementation',
- 'var',
- ' i: byte;',
- ' p: pointer;',
- ' t: PTypeInfo;',
- 'initialization',
- ' p:=typeinfo(i);',
- ' t:=typeinfo(i);',
- ' if p=t then ;',
- ' if p=typeinfo(i) then ;',
- ' if typeinfo(i)=p then ;',
- ' if t=typeinfo(i) then ;',
- ' if typeinfo(i)=t then ;',
- ' DoPtr(p);',
- ' DoPtr(t);',
- ' DoPtr(typeinfo(i));',
- ' DoInfo(p);',
- ' DoInfo(t);',
- ' DoInfo(typeinfo(i));',
- ' DoInt(typeinfo(i));',
- '']);
- ConvertUnit;
- CheckSource('TestRTTI_TypeInfo_MixedUnits_PointerAndClass',
- LinesToStr([ // statements
- 'var $impl = $mod.$impl;',
- '']),
- LinesToStr([ // this.$init
- '$impl.p = rtl.byte;',
- '$impl.t = rtl.byte;',
- 'if ($impl.p === $impl.t) ;',
- 'if ($impl.p === rtl.byte) ;',
- 'if (rtl.byte === $impl.p) ;',
- 'if ($impl.t === rtl.byte) ;',
- 'if (rtl.byte === $impl.t) ;',
- 'pas.unit2.DoPtr($impl.p);',
- 'pas.unit2.DoPtr($impl.t);',
- 'pas.unit2.DoPtr(rtl.byte);',
- 'pas.unit2.DoInfo($impl.p);',
- 'pas.unit2.DoInfo($impl.t);',
- 'pas.unit2.DoInfo(rtl.byte);',
- 'pas.unit2.DoInt(rtl.byte);',
- '']),
- LinesToStr([ // implementation
- '$impl.i = 0;',
- '$impl.p = null;',
- '$impl.t = null;',
- '']) );
- end;
- procedure TTestModule.TestRTTI_Interface_Corba;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add([
- '{$interfaces corba}',
- '{$modeswitch externalclass}',
- 'type',
- ' IUnknown = interface',
- ' end;',
- ' IBird = interface',
- ' function GetItem: longint;',
- ' procedure SetItem(Value: longint);',
- ' property Item: longint read GetItem write SetItem;',
- ' end;',
- 'procedure DoIt(t: TTypeInfoInterface); begin end;',
- 'var',
- ' i: IBird;',
- ' t: TTypeInfoInterface;',
- 'begin',
- ' t:=TypeInfo(IBird);',
- ' t:=TypeInfo(i);',
- ' DoIt(t);',
- ' DoIt(TypeInfo(IBird));',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_Interface_Corba',
- LinesToStr([ // statements
- 'rtl.createInterface(',
- ' this,',
- ' "IUnknown",',
- ' "{B92D5841-758A-322B-B800-000000000000}",',
- ' [],',
- ' null,',
- ' function () {',
- ' }',
- ');',
- 'rtl.createInterface(',
- ' this,',
- ' "IBird",',
- ' "{D32D5841-6264-3AE3-A2C9-B91CE922C9B9}",',
- ' ["GetItem", "SetItem"],',
- ' null,',
- ' function () {',
- ' var $r = this.$rtti;',
- ' $r.addMethod("GetItem", 1, null, rtl.longint);',
- ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
- ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
- ' }',
- ');',
- 'this.DoIt = function (t) {',
- '}; ',
- 'this.i = null;',
- 'this.t = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.t = $mod.$rtti["IBird"];',
- '$mod.t = $mod.i.$rtti;',
- '$mod.DoIt($mod.t);',
- '$mod.DoIt($mod.$rtti["IBird"]);',
- '']));
- end;
- procedure TTestModule.TestRTTI_Interface_COM;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add([
- '{$interfaces com}',
- '{$modeswitch externalclass}',
- 'type',
- ' TGuid = record end;',
- ' integer = longint;',
- ' IUnknown = interface',
- ' function QueryInterface(const iid: TGuid; out obj): Integer;',
- ' function _AddRef: Integer;',
- ' function _Release: Integer;',
- ' end;',
- ' IBird = interface',
- ' function GetItem: longint;',
- ' procedure SetItem(Value: longint);',
- ' property Item: longint read GetItem write SetItem;',
- ' end;',
- 'var',
- ' i: IBird;',
- ' t: TTypeInfoInterface;',
- 'begin',
- ' t:=TypeInfo(IBird);',
- ' t:=TypeInfo(i);',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_Interface_COM',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TGuid", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' $mod.$rtti.$Record("TGuid", {});',
- '});',
- 'rtl.createInterface(',
- ' this,',
- ' "IUnknown",',
- ' "{D7ADB00D-1A9B-3EDC-B123-730E661DDFA9}",',
- ' ["QueryInterface", "_AddRef", "_Release"],',
- ' null,',
- ' function () {',
- ' this.$kind = "com";',
- ' var $r = this.$rtti;',
- ' $r.addMethod("QueryInterface", 1, [["iid", $mod.$rtti["TGuid"], 2], ["obj", null, 4]], rtl.longint);',
- ' $r.addMethod("_AddRef", 1, null, rtl.longint);',
- ' $r.addMethod("_Release", 1, null, rtl.longint);',
- ' }',
- ');',
- 'rtl.createInterface(',
- ' this,',
- ' "IBird",',
- ' "{9CC77572-0E45-3594-9A88-9E8D865C9E0A}",',
- ' ["GetItem", "SetItem"],',
- ' this.IUnknown,',
- ' function () {',
- ' var $r = this.$rtti;',
- ' $r.addMethod("GetItem", 1, null, rtl.longint);',
- ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
- ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
- ' }',
- ');',
- 'this.i = null;',
- 'this.t = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.t = $mod.$rtti["IBird"];',
- '$mod.t = $mod.i.$rtti;',
- '']));
- end;
- procedure TTestModule.TestRTTI_ClassHelper;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add([
- '{$interfaces com}',
- '{$modeswitch externalclass}',
- 'type',
- ' TObject = class',
- ' end;',
- ' THelper = class helper for TObject',
- ' published',
- ' function GetItem: longint;',
- ' property Item: longint read GetItem;',
- ' end;',
- 'function THelper.GetItem: longint;',
- 'begin',
- 'end;',
- 'var',
- ' t: TTypeInfoHelper;',
- 'begin',
- ' t:=TypeInfo(THelper);',
- '']);
- ConvertProgram;
- CheckSource('TestRTTI_ClassHelper',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.GetItem = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("GetItem", 1, null, rtl.longint);',
- ' $r.addProperty("Item", 1, rtl.longint, "GetItem", "");',
- '});',
- 'this.t = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.t = $mod.$rtti["THelper"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_ExternalClass;
- begin
- WithTypeInfo:=true;
- StartProgram(true,[supTypeInfo]);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSObject = class external name ''Object''',
- ' end;',
- ' TJSArray = class external name ''Array'' (TJSObject)',
- ' end;',
- 'var',
- ' p: Pointer;',
- ' tc: TTypeInfoExtClass;',
- 'begin',
- ' p:=typeinfo(TJSArray);']);
- ConvertProgram;
- CheckSource('TestRTTI_ExternalClass',
- LinesToStr([ // statements
- 'this.$rtti.$ExtClass("TJSObject", {',
- ' jsclass: "Object"',
- '});',
- 'this.$rtti.$ExtClass("TJSArray", {',
- ' ancestor: this.$rtti["TJSObject"],',
- ' jsclass: "Array"',
- '});',
- 'this.p = null;',
- 'this.tc = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TJSArray"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_Unit;
- begin
- WithTypeInfo:=true;
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- '{$mode delphi}',
- 'type',
- ' TWordArray = array of word;',
- ' TArray<T> = array of T;',
- '']),
- '');
- StartUnit(true,[supTypeInfo,supTInterfacedObject]);
- Add([
- '{$mode delphi}',
- 'interface',
- 'uses unit2;',
- 'type',
- ' IBird = interface',
- ' function Swoop: TWordArray;',
- ' function Glide: TArray<word>;',
- ' end;',
- 'procedure Fly;',
- 'implementation',
- 'procedure Fly;',
- 'var',
- ' ta: tTypeInfoDynArray;',
- ' ti: tTypeInfoInterface;',
- 'begin',
- ' ta:=typeinfo(TWordArray);',
- ' ta:=typeinfo(TArray<word>);',
- ' ti:=typeinfo(IBird);',
- 'end;',
- '']);
- ConvertUnit;
- CheckSource('TestRTTI_ExternalClass',
- LinesToStr([ // statements
- 'rtl.createInterface(',
- ' this,',
- ' "IBird",',
- ' "{3B98AAAC-6116-3E17-AA85-F16786D85B09}",',
- ' ["Swoop", "Glide"],',
- ' pas.system.IUnknown,',
- ' function () {',
- ' var $r = this.$rtti;',
- ' $r.addMethod("Swoop", 1, null, pas.unit2.$rtti["TWordArray"]);',
- ' $r.addMethod("Glide", 1, null, pas.unit2.$rtti["TArray<System.Word>"]);',
- ' }',
- ');',
- 'this.Fly = function () {',
- ' var ta = null;',
- ' var ti = null;',
- ' ta = pas.unit2.$rtti["TWordArray"];',
- ' ta = pas.unit2.$rtti["TArray<System.Word>"];',
- ' ti = $mod.$rtti["IBird"];',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestResourcestringProgram;
- begin
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- 'resourcestring Title = ''Nice'';',
- '']),
- '');
- StartProgram(true);
- Add([
- 'uses unit2;',
- 'const Bar = ''bar'';',
- 'resourcestring',
- ' Red = ''red'';',
- ' Foobar = ''fOo''+bar;',
- 'var s: string;',
- ' c: char;',
- 'begin',
- ' s:=red;',
- ' s:=test1.red;',
- ' s:=Title;',
- ' c:=red[1];',
- ' c:=test1.red[2];',
- ' if red=foobar then ;',
- ' if red[3]=red[4] then ;']);
- ConvertProgram;
- CheckSource('TestResourcestringProgram',
- LinesToStr([ // statements
- 'this.Bar = "bar";',
- 'this.s = "";',
- 'this.c = "";',
- '$mod.$resourcestrings = {',
- ' Red: {',
- ' org: "red"',
- ' },',
- ' Foobar: {',
- ' org: "fOobar"',
- ' }',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.s = rtl.getResStr($mod, "Red");',
- '$mod.s = rtl.getResStr($mod, "Red");',
- '$mod.s = rtl.getResStr(pas.unit2, "Title");',
- '$mod.c = rtl.getResStr($mod, "Red").charAt(0);',
- '$mod.c = rtl.getResStr($mod, "Red").charAt(1);',
- 'if (rtl.getResStr($mod, "Red") === rtl.getResStr($mod, "Foobar")) ;',
- 'if (rtl.getResStr($mod, "Red").charAt(2) === rtl.getResStr($mod, "Red").charAt(3)) ;',
- '']));
- end;
- procedure TTestModule.TestResourcestringUnit;
- begin
- AddModuleWithIntfImplSrc('unit2.pas',
- LinesToStr([
- 'resourcestring Title = ''Nice'';',
- '']),
- '');
- StartUnit(true);
- Add([
- 'interface',
- 'uses unit2;',
- 'const Red = ''rEd'';',
- 'resourcestring',
- ' Blue = ''blue'';',
- ' NotRed = ''not''+Red;',
- 'var s: string;',
- 'implementation',
- 'resourcestring',
- ' ImplGreen = ''green'';',
- 'initialization',
- ' s:=blue+ImplGreen;',
- ' s:=test1.blue+test1.implgreen;',
- ' s:=blue[1]+implgreen[2];',
- ' s:=Title;',
- '']);
- ConvertUnit;
- CheckSource('TestResourcestringUnit',
- LinesToStr([ // statements
- 'this.Red = "rEd";',
- 'this.s = "";',
- '$mod.$resourcestrings = {',
- ' Blue: {',
- ' org: "blue"',
- ' },',
- ' NotRed: {',
- ' org: "notrEd"',
- ' },',
- ' ImplGreen: {',
- ' org: "green"',
- ' }',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.s = rtl.getResStr($mod, "Blue") + rtl.getResStr($mod, "ImplGreen");',
- '$mod.s = rtl.getResStr($mod, "Blue") + rtl.getResStr($mod, "ImplGreen");',
- '$mod.s = rtl.getResStr($mod, "Blue").charAt(0) + rtl.getResStr($mod, "ImplGreen").charAt(1);',
- '$mod.s = rtl.getResStr(pas.unit2, "Title");',
- '']));
- end;
- procedure TTestModule.TestResourcestringImplementation;
- begin
- StartUnit(false);
- Add([
- 'interface',
- 'implementation',
- 'resourcestring',
- ' ImplRed = ''red'';']);
- ConvertUnit;
- CheckSource('TestResourcestringImplementation',
- LinesToStr([ // intf statements
- 'var $impl = $mod.$impl;']),
- LinesToStr([ // $mod.$init
- '']),
- LinesToStr([ // impl statements
- '$mod.$resourcestrings = {',
- ' ImplRed: {',
- ' org: "red"',
- ' }',
- '};',
- '']));
- end;
- procedure TTestModule.TestAttributes_Members;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- '{$modeswitch PrefixedAttributes}',
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- ' TCustomAttribute = class',
- ' constructor Create(Id: word);',
- ' end;',
- ' [Missing]',
- ' TBird = class',
- ' published',
- ' [Tcustom]',
- ' FField: word;',
- ' [tcustom(14)]',
- ' property Size: word read FField;',
- ' [Tcustom(15)]',
- ' procedure Fly; virtual; abstract;',
- ' end;',
- ' TRec = record',
- ' [Tcustom,tcustom(14)]',
- ' Size: word;',
- ' end;',
- 'constructor TObject.Create; begin end;',
- 'constructor TCustomAttribute.Create(Id: word); begin end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestAttributes_Members',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TCustomAttribute", this.TObject, function () {',
- ' this.Create$1 = function (Id) {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FField = 0;',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addField("FField", rtl.word, {',
- ' attr: [$mod.TCustomAttribute, "Create"]',
- ' });',
- ' $r.addProperty(',
- ' "Size",',
- ' 0,',
- ' rtl.word,',
- ' "FField",',
- ' "",',
- ' {',
- ' attr: [$mod.TCustomAttribute, "Create$1", [14]]',
- ' }',
- ' );',
- ' $r.addMethod("Fly", 0, null, null, {',
- ' attr: [$mod.TCustomAttribute, "Create$1", [15]]',
- ' });',
- '});',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.Size = 0;',
- ' this.$eq = function (b) {',
- ' return this.Size === b.Size;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Size = s.Size;',
- ' return this;',
- ' };',
- ' var $r = $mod.$rtti.$Record("TRec", {});',
- ' $r.addField("Size", rtl.word, {',
- ' attr: [',
- ' $mod.TCustomAttribute,',
- ' "Create",',
- ' $mod.TCustomAttribute,',
- ' "Create$1",',
- ' [14]',
- ' ]',
- ' });',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestAttributes_Types;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- '{$modeswitch PrefixedAttributes}',
- 'type',
- ' TObject = class',
- ' constructor Create(Id: word);',
- ' end;',
- ' TCustomAttribute = class',
- ' end;',
- ' [TCustom(1)]',
- ' TMyClass = class',
- ' end;',
- ' [TCustom(11)]',
- ' TMyDescendant = class(TMyClass)',
- ' end;',
- ' [TCustom(2)]',
- ' TRec = record',
- ' end;',
- ' [TCustom(3)]',
- ' TInt = type word;',
- 'constructor TObject.Create(Id: word);',
- 'begin',
- 'end;',
- 'var p: pointer;',
- 'begin',
- ' p:=typeinfo(TMyClass);',
- ' p:=typeinfo(TRec);',
- ' p:=typeinfo(TInt);',
- '']);
- ConvertProgram;
- CheckSource('TestAttributes_Types',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function (Id) {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TCustomAttribute", this.TObject, function () {',
- '});',
- 'rtl.createClass(this, "TMyClass", this.TObject, function () {',
- ' var $r = this.$rtti;',
- ' $r.attr = [$mod.TCustomAttribute, "Create", [1]];',
- '});',
- 'rtl.createClass(this, "TMyDescendant", this.TMyClass, function () {',
- ' var $r = this.$rtti;',
- ' $r.attr = [$mod.TCustomAttribute, "Create", [11]];',
- '});',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.$eq = function (b) {',
- ' return true;',
- ' };',
- ' this.$assign = function (s) {',
- ' return this;',
- ' };',
- ' $mod.$rtti.$Record("TRec", {',
- ' attr: [$mod.TCustomAttribute, "Create", [2]]',
- ' });',
- '});',
- 'this.$rtti.$inherited("TInt", rtl.word, {',
- ' attr: [this.TCustomAttribute, "Create", [3]]',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TMyClass"];',
- '$mod.p = $mod.$rtti["TRec"];',
- '$mod.p = $mod.$rtti["TInt"];',
- '']));
- end;
- procedure TTestModule.TestAttributes_HelperConstructor_Fail;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- '{$modeswitch PrefixedAttributes}',
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- ' TCustomAttribute = class',
- ' end;',
- ' THelper = class helper for TCustomAttribute',
- ' constructor Create(Id: word);',
- ' end;',
- ' [TCustom(3)]',
- ' TMyInt = word;',
- 'constructor TObject.Create; begin end;',
- 'constructor THelper.Create(Id: word); begin end;',
- 'begin',
- ' if typeinfo(TMyInt)=nil then ;']);
- ConvertProgram;
- end;
- procedure TTestModule.TestAssert;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt;',
- 'var',
- ' b: boolean;',
- ' s: string;',
- 'begin',
- ' {$Assertions on}',
- ' Assert(b);',
- 'end;',
- 'begin',
- ' DoIt;',
- '']);
- ConvertProgram;
- CheckSource('TestAssert',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' var b = false;',
- ' var s = "";',
- ' if (!b) throw "assert failed";',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt();',
- '']));
- end;
- procedure TTestModule.TestAssert_SysUtils;
- begin
- AddModuleWithIntfImplSrc('SysUtils.pas',
- LinesToStr([
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- ' EAssertionFailed = class',
- ' constructor Create(s: string);',
- ' end;',
- '']),
- LinesToStr([
- 'constructor TObject.Create;',
- 'begin end;',
- 'constructor EAssertionFailed.Create(s: string);',
- 'begin end;',
- '']) );
- StartProgram(true);
- Add([
- 'uses sysutils;',
- 'procedure DoIt;',
- 'var',
- ' b: boolean;',
- ' s: string;',
- 'begin',
- ' {$Assertions on}',
- ' Assert(b);',
- ' Assert(b,''msg'');',
- 'end;',
- 'begin',
- ' DoIt;',
- '']);
- ConvertProgram;
- CheckSource('TestAssert_SysUtils',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' var b = false;',
- ' var s = "";',
- ' if (!b) throw pas.SysUtils.EAssertionFailed.$create("Create");',
- ' if (!b) throw pas.SysUtils.EAssertionFailed.$create("Create$1", ["msg"]);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt();',
- '']));
- end;
- procedure TTestModule.TestObjectChecks;
- begin
- Scanner.CurrentBoolSwitches:=Scanner.CurrentBoolSwitches+[bsObjectChecks];
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' procedure DoIt;',
- ' end;',
- ' TClass = class of tobject;',
- ' TBird = class',
- ' end;',
- ' TBirdClass = class of TBird;',
- 'var',
- ' o : TObject;',
- ' c: TClass;',
- ' b: TBird;',
- ' bc: TBirdClass;',
- 'procedure TObject.DoIt;',
- 'begin',
- ' b:=TBird(o);',
- 'end;',
- 'begin',
- ' o.DoIt;',
- ' b:=TBird(o);',
- ' bc:=TBirdClass(c);',
- '']);
- ConvertProgram;
- CheckSource('TestCheckMethodCall',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' rtl.checkMethodCall(this,$mod.TObject);',
- ' $mod.b = rtl.asExt($mod.o, $mod.TBird, 1);',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- '});',
- 'this.o = null;',
- 'this.c = null;',
- 'this.b = null;',
- 'this.bc = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.o.DoIt();',
- '$mod.b = rtl.asExt($mod.o,$mod.TBird, 1);',
- '$mod.bc = rtl.asExt($mod.c, $mod.TBird, 2);',
- '']));
- end;
- procedure TTestModule.TestOverflowChecks_Int;
- begin
- Scanner.CurrentBoolSwitches:=Scanner.CurrentBoolSwitches+[bsOverflowChecks];
- StartProgram(false);
- Add([
- 'procedure DoIt;',
- 'var',
- ' b: byte;',
- ' n: nativeint;',
- ' u: nativeuint;',
- ' c: currency;',
- 'begin',
- ' n:=n+n;',
- ' n:=n-n;',
- ' n:=n+b;',
- ' n:=b-n;',
- ' n:=n*n;',
- ' n:=n*u;',
- ' c:=c+b;',
- ' c:=b+c;',
- ' c:=c*b;',
- ' c:=b*c;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestOverflowChecks_Int',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' var b = 0;',
- ' var n = 0;',
- ' var u = 0;',
- ' var c = 0;',
- ' n = rtl.oc(n + n);',
- ' n = rtl.oc(n - n);',
- ' n = rtl.oc(n + b);',
- ' n = rtl.oc(b - n);',
- ' n = rtl.oc(n * n);',
- ' n = rtl.oc(n * u);',
- ' c = rtl.oc(c + (b * 10000));',
- ' c = rtl.oc((b * 10000) + c);',
- ' c = rtl.oc(c * b);',
- ' c = rtl.oc(b * c);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_AssignInt;
- begin
- Scanner.Options:=Scanner.Options+[po_CAssignments];
- StartProgram(false);
- Add([
- '{$R+}',
- 'var',
- ' b: byte = 2;',
- ' w: word = 3;',
- 'procedure DoIt(p: byte);',
- 'begin',
- ' b:=w;',
- ' b+=w;',
- ' b:=1;',
- 'end;',
- '{$R-}',
- 'procedure DoSome;',
- 'begin',
- ' DoIt(w);',
- ' b:=w;',
- ' b:=2;',
- 'end;',
- 'begin',
- '{$R+}',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_AssignInt',
- LinesToStr([ // statements
- 'this.b = 2;',
- 'this.w = 3;',
- 'this.DoIt = function (p) {',
- ' rtl.rc(p, 0, 255);',
- ' $mod.b = rtl.rc($mod.w,0,255);',
- ' rtl.rc($mod.b += $mod.w, 0, 255);',
- ' $mod.b = 1;',
- '};',
- 'this.DoSome = function () {',
- ' $mod.DoIt($mod.w);',
- ' $mod.b = $mod.w;',
- ' $mod.b = 2;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_AssignIntRange;
- begin
- Scanner.Options:=Scanner.Options+[po_CAssignments];
- StartProgram(false);
- Add([
- '{$R+}',
- 'type Ten = 1..10;',
- 'var',
- ' b: Ten = 2;',
- ' w: Ten = 3;',
- 'procedure DoIt(p: Ten);',
- 'begin',
- ' b:=w;',
- ' b+=w;',
- ' b:=1;',
- 'end;',
- '{$R-}',
- 'procedure DoSome;',
- 'begin',
- ' DoIt(w);',
- ' b:=w;',
- ' b:=2;',
- 'end;',
- 'begin',
- '{$R+}',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_AssignIntRange',
- LinesToStr([ // statements
- 'this.b = 2;',
- 'this.w = 3;',
- 'this.DoIt = function (p) {',
- ' rtl.rc(p, 1, 10);',
- ' $mod.b = rtl.rc($mod.w, 1, 10);',
- ' rtl.rc($mod.b += $mod.w, 1, 10);',
- ' $mod.b = 1;',
- '};',
- 'this.DoSome = function () {',
- ' $mod.DoIt($mod.w);',
- ' $mod.b = $mod.w;',
- ' $mod.b = 2;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_AssignEnum;
- begin
- StartProgram(false);
- Add([
- '{$R+}',
- 'type TEnum = (red,green);',
- 'var',
- ' e: TEnum = red;',
- 'procedure DoIt(p: TEnum);',
- 'begin',
- ' e:=p;',
- ' p:=TEnum(0);',
- ' p:=succ(e);',
- 'end;',
- '{$R-}',
- 'procedure DoSome;',
- 'begin',
- ' DoIt(e);',
- ' e:=TEnum(1);',
- ' e:=pred(e);',
- 'end;',
- 'begin',
- '{$R+}',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_AssignEnum',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "green",',
- ' green: 1',
- '};',
- 'this.e = this.TEnum.red;',
- 'this.DoIt = function (p) {',
- ' rtl.rc(p, 0, 1);',
- ' $mod.e = rtl.rc(p, 0, 1);',
- ' p = 0;',
- ' p = rtl.rc($mod.e + 1, 0, 1);',
- '};',
- 'this.DoSome = function () {',
- ' $mod.DoIt($mod.e);',
- ' $mod.e = 1;',
- ' $mod.e = $mod.e - 1;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_AssignEnumRange;
- begin
- StartProgram(false);
- Add([
- '{$R+}',
- 'type',
- ' TEnum = (red,green);',
- ' TEnumRg = red..green;',
- 'var',
- ' e: TEnumRg = red;',
- 'procedure DoIt(p: TEnumRg);',
- 'begin',
- ' e:=p;',
- ' p:=TEnumRg(0);',
- ' p:=succ(e);',
- 'end;',
- '{$R-}',
- 'procedure DoSome;',
- 'begin',
- ' DoIt(e);',
- ' e:=TEnum(1);',
- ' e:=pred(e);',
- 'end;',
- 'begin',
- '{$R+}',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_AssignEnumRange',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "green",',
- ' green: 1',
- '};',
- 'this.e = this.TEnum.red;',
- 'this.DoIt = function (p) {',
- ' rtl.rc(p, 0, 1);',
- ' $mod.e = rtl.rc(p, 0, 1);',
- ' p = 0;',
- ' p = rtl.rc($mod.e + 1, 0, 1);',
- '};',
- 'this.DoSome = function () {',
- ' $mod.DoIt($mod.e);',
- ' $mod.e = 1;',
- ' $mod.e = $mod.e - 1;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_AssignChar;
- begin
- StartProgram(false);
- Add([
- '{$R+}',
- 'type',
- ' TLetter = char;',
- 'var',
- ' b: TLetter = ''2'';',
- ' w: TLetter = ''3'';',
- 'procedure DoIt(p: TLetter);',
- 'begin',
- ' b:=w;',
- ' b:=''1'';',
- 'end;',
- '{$R-}',
- 'procedure DoSome;',
- 'begin',
- ' DoIt(w);',
- ' b:=w;',
- ' b:=''2'';',
- 'end;',
- 'begin',
- '{$R+}',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_AssignChar',
- LinesToStr([ // statements
- 'this.b = "2";',
- 'this.w = "3";',
- 'this.DoIt = function (p) {',
- ' rtl.rcc(p, 0, 65535);',
- ' $mod.b = rtl.rcc($mod.w, 0, 65535);',
- ' $mod.b = "1";',
- '};',
- 'this.DoSome = function () {',
- ' $mod.DoIt($mod.w);',
- ' $mod.b = $mod.w;',
- ' $mod.b = "2";',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_AssignCharRange;
- begin
- StartProgram(false);
- Add([
- '{$R+}',
- 'type TDigit = ''0''..''9'';',
- 'var',
- ' b: TDigit = ''2'';',
- ' w: TDigit = ''3'';',
- 'procedure DoIt(p: TDigit);',
- 'begin',
- ' b:=w;',
- ' b:=''1'';',
- 'end;',
- '{$R-}',
- 'procedure DoSome;',
- 'begin',
- ' DoIt(w);',
- ' b:=w;',
- ' b:=''2'';',
- 'end;',
- 'begin',
- '{$R+}',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_AssignCharRange',
- LinesToStr([ // statements
- 'this.b = "2";',
- 'this.w = "3";',
- 'this.DoIt = function (p) {',
- ' rtl.rcc(p, 48, 57);',
- ' $mod.b = rtl.rcc($mod.w, 48, 57);',
- ' $mod.b = "1";',
- '};',
- 'this.DoSome = function () {',
- ' $mod.DoIt($mod.w);',
- ' $mod.b = $mod.w;',
- ' $mod.b = "2";',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_ArrayIndex;
- begin
- StartProgram(false);
- Add([
- '{$R+}',
- 'type',
- ' Ten = 1..10;',
- ' TArr = array of Ten;',
- ' TArrArr = array of TArr;',
- ' TArrByte = array[byte] of Ten;',
- ' TArrChar = array[''0''..''9''] of Ten;',
- ' TArrByteChar = array[byte,''0''..''9''] of Ten;',
- ' TObject = class',
- ' A: TArr;',
- ' end;',
- 'procedure DoIt;',
- 'var',
- ' Arr: TArr;',
- ' ArrArr: TArrArr;',
- ' ArrByte: TArrByte;',
- ' ArrChar: TArrChar;',
- ' ArrByteChar: TArrByteChar;',
- ' i: Ten;',
- ' c: char;',
- ' o: tobject;',
- 'begin',
- ' i:=Arr[1];',
- ' i:=ArrByteChar[1,''2''];',
- ' Arr[1]:=Arr[1];',
- ' Arr[i]:=Arr[i];',
- ' ArrByte[3]:=ArrByte[3];',
- ' ArrByte[i]:=ArrByte[i];',
- ' ArrChar[''5'']:=ArrChar[''5''];',
- ' ArrChar[c]:=ArrChar[c];',
- ' ArrByteChar[7,''7'']:=ArrByteChar[7,''7''];',
- ' ArrByteChar[i,c]:=ArrByteChar[i,c];',
- ' o.a[i]:=o.a[i];',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_ArrayIndex',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.A = [];',
- ' };',
- ' this.$final = function () {',
- ' this.A = undefined;',
- ' };',
- '});',
- 'this.DoIt = function () {',
- ' var Arr = [];',
- ' var ArrArr = [];',
- ' var ArrByte = rtl.arraySetLength(null, 0, 256);',
- ' var ArrChar = rtl.arraySetLength(null, 0, 10);',
- ' var ArrByteChar = rtl.arraySetLength(null, 0, 256, 10);',
- ' var i = 0;',
- ' var c = "";',
- ' var o = null;',
- ' i = rtl.rc(Arr[1], 1, 10);',
- ' i = rtl.rc(ArrByteChar[1][2], 1, 10);',
- ' Arr[1] = rtl.rc(Arr[1], 1, 10);',
- ' rtl.rcArrW(Arr, i, rtl.rcArrR(Arr, i));',
- ' ArrByte[3] = rtl.rc(ArrByte[3], 1, 10);',
- ' rtl.rcArrW(ArrByte, i, rtl.rcArrR(ArrByte, i));',
- ' ArrChar[5] = rtl.rc(ArrChar[5], 1, 10);',
- ' rtl.rcArrW(ArrChar, c.charCodeAt() - 48, rtl.rcArrR(ArrChar, c.charCodeAt() - 48));',
- ' ArrByteChar[7][7] = rtl.rc(ArrByteChar[7][7], 1, 10);',
- ' rtl.rcArrW(ArrByteChar, i, c.charCodeAt() - 48, rtl.rcArrR(ArrByteChar, i, c.charCodeAt() - 48));',
- ' rtl.rcArrW(o.A, i, rtl.rcArrR(o.A, i));',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_ArrayOfRecIndex;
- begin
- StartProgram(false);
- Add([
- '{$R+}',
- 'type',
- ' Ten = 1..10;',
- ' TRec = record x: Ten end;',
- ' TArr = array of TRec;',
- ' TArrArr = array of TArr;',
- ' TObject = class',
- ' A: TArr;',
- ' end;',
- 'procedure DoIt;',
- 'var',
- ' Arr: TArr;',
- ' ArrArr: TArrArr;',
- ' i: Ten;',
- ' o: tobject;',
- 'begin',
- ' Arr[1]:=Arr[1];',
- ' Arr[i]:=Arr[i+1];',
- ' o.a[i]:=o.a[i+2];',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_ArrayOfRecIndex',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.x = 0;',
- ' this.$eq = function (b) {',
- ' return this.x === b.x;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.x = s.x;',
- ' return this;',
- ' };',
- '});',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.A = [];',
- ' };',
- ' this.$final = function () {',
- ' this.A = undefined;',
- ' };',
- '});',
- 'this.DoIt = function () {',
- ' var Arr = [];',
- ' var ArrArr = [];',
- ' var i = 0;',
- ' var o = null;',
- ' Arr[1].$assign(Arr[1]);',
- ' rtl.rcArrR(Arr, i).$assign(rtl.rcArrR(Arr, i + 1));',
- ' rtl.rcArrR(o.A, i).$assign(rtl.rcArrR(o.A, i + 2));',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_StringIndex;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' S: string;',
- ' end;',
- '{$R+}',
- 'procedure DoIt(var h: string);',
- 'var',
- ' s: string;',
- ' i: longint;',
- ' c: char;',
- ' o: tobject;',
- 'begin',
- ' c:=s[1];',
- ' s[i]:=s[i];',
- ' h[i]:=h[i];',
- ' c:=o.s[i];',
- ' o.s[i]:=c;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_StringIndex',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.S = "";',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.DoIt = function (h) {',
- ' var s = "";',
- ' var i = 0;',
- ' var c = "";',
- ' var o = null;',
- ' c = rtl.rcc(rtl.rcCharAt(s, 0), 0, 65535);',
- ' s = rtl.rcSetCharAt(s, i - 1, rtl.rcCharAt(s, i - 1));',
- ' h.set(rtl.rcSetCharAt(h.get(), i - 1, rtl.rcCharAt(h.get(), i - 1)));',
- ' c = rtl.rcc(rtl.rcCharAt(o.S, i - 1), 0, 65535);',
- ' o.S = rtl.rcSetCharAt(o.S, i - 1, c);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRangeChecks_TypecastInt;
- begin
- StartProgram(false);
- Add([
- '{$R+}',
- 'var',
- ' i: nativeint;',
- ' b: byte;',
- ' sh: shortint;',
- ' w: word;',
- ' sm: smallint;',
- ' lw: longword;',
- ' li: longint;',
- 'begin',
- ' b:=12+byte(i);',
- ' sh:=12+shortint(i);',
- ' w:=12+word(i);',
- ' sm:=12+smallint(i);',
- ' lw:=12+longword(i);',
- ' li:=12+longint(i);',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_TypecastInt',
- LinesToStr([
- 'this.i = 0;',
- 'this.b = 0;',
- 'this.sh = 0;',
- 'this.w = 0;',
- 'this.sm = 0;',
- 'this.lw = 0;',
- 'this.li = 0;',
- '']),
- LinesToStr([
- '$mod.b = rtl.rc(12 + rtl.rc($mod.i, 0, 255), 0, 255);',
- '$mod.sh = rtl.rc(12 + rtl.rc($mod.i, -128, 127), -128, 127);',
- '$mod.w = rtl.rc(12 + rtl.rc($mod.i, 0, 65535), 0, 65535);',
- '$mod.sm = rtl.rc(12 + rtl.rc($mod.i, -32768, 32767), -32768, 32767);',
- '$mod.lw = rtl.rc(12 + rtl.rc($mod.i, 0, 4294967295), 0, 4294967295);',
- '$mod.li = rtl.rc(12 + rtl.rc($mod.i, -2147483648, 2147483647), -2147483648, 2147483647);',
- '']));
- end;
- procedure TTestModule.TestRangeChecks_TypeHelperInt;
- begin
- Scanner.Options:=Scanner.Options+[po_CAssignments];
- StartProgram(false);
- Add([
- '{$modeswitch typehelpers}',
- '{$R+}',
- 'type',
- ' TObject = class',
- ' FSize: byte;',
- ' property Size: byte read FSize;',
- ' end;',
- ' THelper = type helper for byte',
- ' procedure SetIt(w: word);',
- ' end;',
- 'procedure THelper.SetIt(w: word);',
- 'begin',
- ' Self:=w;',
- 'end;',
- 'function GetIt: byte;',
- 'begin',
- ' Result.SetIt(2);',
- 'end;',
- 'var',
- ' b: byte = 3;',
- ' o: TObject;',
- 'begin',
- ' b.SetIt(14);',
- ' with b do SetIt(15);',
- ' o.Size.SetIt(16);',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_AssignInt',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FSize = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createHelper(this, "THelper", null, function () {',
- ' this.SetIt = function (w) {',
- ' rtl.rc(w, 0, 65535);',
- ' this.set(w);',
- ' };',
- '});',
- 'this.GetIt = function () {',
- ' var Result = 0;',
- ' $mod.THelper.SetIt.call({',
- ' get: function () {',
- ' return Result;',
- ' },',
- ' set: function (v) {',
- ' rtl.rc(v, 0, 255);',
- ' Result = v;',
- ' }',
- ' }, 2);',
- ' return Result;',
- '};',
- 'this.b = 3;',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.THelper.SetIt.call({',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.b;',
- ' },',
- ' set: function (v) {',
- ' rtl.rc(v, 0, 255);',
- ' this.p.b = v;',
- ' }',
- '}, 14);',
- 'var $with = $mod.b;',
- '$mod.THelper.SetIt.call({',
- ' get: function () {',
- ' return $with;',
- ' },',
- ' set: function (v) {',
- ' rtl.rc(v, 0, 255);',
- ' $with = v;',
- ' }',
- '}, 15);',
- '$mod.THelper.SetIt.call({',
- ' p: $mod.o,',
- ' get: function () {',
- ' return this.p.FSize;',
- ' },',
- ' set: function (v) {',
- ' rtl.rc(v, 0, 255);',
- ' this.p.FSize = v;',
- ' }',
- '}, 16);',
- '']));
- end;
- procedure TTestModule.TestAsync_Proc;
- begin
- StartProgram(false);
- Add([
- 'procedure Fly(w: word = 1); async; forward;',
- 'procedure Run(w: word = 2); async;',
- 'begin',
- ' Fly(w);',
- ' Fly;',
- ' await(Fly(w));',
- ' await(Fly);',
- 'end;',
- 'procedure Fly(w: word); ',
- 'begin',
- 'end;',
- 'begin',
- ' Run;',
- ' Run(3);',
- '']);
- CheckResolverUnexpectedHints();
- ConvertProgram;
- CheckSource('TestAsync_Proc',
- LinesToStr([ // statements
- 'this.Run = async function (w) {',
- ' $mod.Fly(w);',
- ' $mod.Fly(1);',
- ' await $mod.Fly(w);',
- ' await $mod.Fly(1);',
- '};',
- 'this.Fly = async function (w) {',
- '};',
- '']),
- LinesToStr([
- '$mod.Run(2);',
- '$mod.Run(3);',
- '']));
- end;
- procedure TTestModule.TestAsync_CallResultIsPromise;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TObject = class',
- ' end;',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' TBird = class',
- ' function Fly: word; async; ',
- ' end;',
- 'function TBird.Fly: word; async; ',
- 'begin',
- ' Result:=3;',
- ' Fly:=4+Result;',
- ' if Result=5 then ;',
- ' exit(6);',
- 'end;',
- 'function Run: word; async;',
- 'begin',
- ' Result:=11+Result;',
- ' inc(Result);',
- 'end;',
- 'var',
- ' p: TJSPromise;',
- ' o: TBird;',
- 'begin',
- ' p:=Run;',
- ' p:=Run();',
- ' if Run=p then ;',
- ' if p=Run then ;',
- ' if Run()=p then ;',
- ' if p=Run() then ;',
- ' p:=o.Fly;',
- ' p:=o.Fly();',
- ' if o.Fly=p then ;',
- ' if o.Fly()=p then ;',
- ' with o do begin',
- ' p:=Fly;',
- ' p:=Fly();',
- ' if Fly=p then ;',
- ' if Fly()=p then ;',
- ' end;',
- '']);
- CheckResolverUnexpectedHints();
- ConvertProgram;
- CheckSource('TestAsync_CallResultIsPromise',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Fly = async function () {',
- ' var Result = 0;',
- ' Result = 3;',
- ' Result = 4 + Result;',
- ' if (Result === 5) ;',
- ' return 6;',
- ' return Result;',
- ' };',
- '});',
- 'this.Run = async function () {',
- ' var Result = 0;',
- ' Result = 11 + Result;',
- ' Result += 1;',
- ' return Result;',
- '};',
- 'this.p = null;',
- 'this.o = null;',
- '']),
- LinesToStr([
- '$mod.p = $mod.Run();',
- '$mod.p = $mod.Run();',
- 'if ($mod.Run() === $mod.p) ;',
- 'if ($mod.p === $mod.Run()) ;',
- 'if ($mod.Run() === $mod.p) ;',
- 'if ($mod.p === $mod.Run()) ;',
- '$mod.p = $mod.o.Fly();',
- '$mod.p = $mod.o.Fly();',
- 'if ($mod.o.Fly() === $mod.p) ;',
- 'if ($mod.o.Fly() === $mod.p) ;',
- 'var $with = $mod.o;',
- '$mod.p = $with.Fly();',
- '$mod.p = $with.Fly();',
- 'if ($with.Fly() === $mod.p) ;',
- 'if ($with.Fly() === $mod.p) ;',
- '']));
- end;
- procedure TTestModule.TestAsync_ConstructorFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' end;',
- ' TBird = class',
- ' constructor Create; async;',
- ' end;',
- 'constructor TBird.Create; async;',
- 'begin',
- 'end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Invalid constructor modifier async',nInvalidXModifierY);
- ConvertProgram;
- end;
- procedure TTestModule.TestAsync_PropertyGetterFail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' end;',
- ' TBird = class',
- ' function GetSize: word; async;',
- ' property Size: word read GetSize;',
- ' end;',
- 'function TBird.GetSize: word; async;',
- 'begin',
- 'end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Invalid property getter modifier async',nInvalidXModifierY);
- ConvertProgram;
- end;
- procedure TTestModule.TestAwait_NonPromiseWithTypeFail;
- begin
- StartProgram(false);
- Add([
- 'procedure Run; async;',
- 'begin',
- ' await(word,1);',
- 'end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Incompatible type arg no. 2: Got "Longint", expected "TJSPromise"',nIncompatibleTypeArgNo);
- ConvertProgram;
- end;
- procedure TTestModule.TestAwait_AsyncCallTypeMismatch;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' end;',
- ' TBird = class',
- ' end;',
- 'function Fly: TObject; async;',
- 'begin',
- 'end;',
- 'procedure Run; async;',
- 'begin',
- ' await(TBird,Fly);',
- 'end;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Incompatible type arg no. 2: Got "TObject", expected "TBird"',nIncompatibleTypeArgNo);
- ConvertProgram;
- end;
- procedure TTestModule.TestAWait_OutsideAsyncFail;
- begin
- StartProgram(false);
- Add([
- 'procedure Crawl(w: double); ',
- 'begin',
- 'end;',
- 'procedure Run(w: double);',
- 'begin',
- ' await(Crawl(w));',
- 'end;',
- 'begin',
- ' Run(1);']);
- SetExpectedPasResolverError(sAWaitOnlyInAsyncProcedure,nAWaitOnlyInAsyncProcedure);
- ConvertProgram;
- end;
- procedure TTestModule.TestAWait_IntegerFail;
- begin
- StartProgram(false);
- Add([
- 'function Run: word;',
- 'begin',
- 'end;',
- 'procedure Fly(w: word); async;',
- 'begin',
- ' await(Run());',
- 'end;',
- 'begin',
- ' Fly(1);']);
- SetExpectedPasResolverError('async function expected, but Result:Word found',nXExpectedButYFound);
- ConvertProgram;
- end;
- procedure TTestModule.TestAWait_ExternalClassPromise;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' TJSThenable = class external name ''Thenable''',
- ' end;',
- 'function Fly(w: word): TJSPromise;',
- 'begin',
- 'end;',
- 'function Jump(w: word): word; async;',
- 'begin',
- 'end;',
- 'function Eat(w: word): TJSPromise; async;',
- 'begin',
- 'end;',
- 'function Run(d: double): word; async;',
- 'var',
- ' p: TJSPromise;',
- 'begin',
- ' Result:=await(word,p);', // promise needs type
- ' Result:=await(word,Fly(3));', // promise needs type
- ' Result:=await(Jump(4));', // async non promise must omit the type
- ' Result:=await(word,Jump(5));', // async call can provide fitting type
- ' Result:=await(word,Eat(6));', // promise needs type
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestAWait_ExternalClassPromise',
- LinesToStr([ // statements
- 'this.Fly = function (w) {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.Jump = async function (w) {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.Eat = async function (w) {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.Run = async function (d) {',
- ' var Result = 0;',
- ' var p = null;',
- ' Result = await p;',
- ' Result = await $mod.Fly(3);',
- ' Result = await $mod.Jump(4);',
- ' Result = await $mod.Jump(5);',
- ' Result = await $mod.Eat(6);',
- ' return Result;',
- '};',
- '']),
- LinesToStr([
- ]));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestAWait_JSValue;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- 'function Fly(w: word): jsvalue; async;',
- 'begin',
- 'end;',
- 'function Run(d: jsvalue; var e): word; async;',
- 'begin',
- ' Result:=await(word,d);', // promise needs type
- ' d:=await(Fly(4));', // async non promise must omit the type
- ' Result:=await(word,e);', // promise needs type
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestAWait_JSValue',
- LinesToStr([ // statements
- 'this.Fly = async function (w) {',
- ' var Result = undefined;',
- ' return Result;',
- '};',
- 'this.Run = async function (d, e) {',
- ' var Result = 0;',
- ' Result = await d;',
- ' d = await $mod.Fly(4);',
- ' Result = await e.get();',
- ' return Result;',
- '};',
- '']),
- LinesToStr([
- ]));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestAWait_Result;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- 'function Crawl(d: double = 1.3): TJSPromise; ',
- 'begin',
- 'end;',
- 'function Run(d: double = 1.6): word; async;',
- 'begin',
- ' Result:=await(word,Crawl);',
- ' Result:=await(word,Crawl(4.5));',
- ' Result:=await(Run);',
- ' Result:=await(Run(6.7));',
- 'end;',
- 'begin',
- ' Run(1);']);
- ConvertProgram;
- CheckSource('TestAWait_Result',
- LinesToStr([ // statements
- 'this.Crawl = function (d) {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.Run = async function (d) {',
- ' var Result = 0;',
- ' Result = await $mod.Crawl(1.3);',
- ' Result = await $mod.Crawl(4.5);',
- ' Result = await $mod.Run(1.6);',
- ' Result = await $mod.Run(6.7);',
- ' return Result;',
- '};',
- '']),
- LinesToStr([
- '$mod.Run(1);'
- ]));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestAWait_ResultPromiseMissingTypeFail;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- 'function Run: TJSPromise; async;',
- 'begin',
- 'end;',
- 'procedure Fly(w: word); async;',
- 'begin',
- ' await(Run());',
- 'end;',
- 'begin',
- ' Fly(1);']);
- SetExpectedPasResolverError('Wrong number of parameters specified for call to "function await(aType,TJSPromise):aType"',
- nWrongNumberOfParametersForCallTo);
- ConvertProgram;
- end;
- procedure TTestModule.TestAsync_AnonymousProc;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- 'type',
- ' TFunc = reference to function(x: double): word; async;',
- 'function Crawl(d: double = 1.3): word; async;',
- 'begin',
- 'end;',
- 'var Func: TFunc;',
- 'begin',
- ' Func:=function(c:double):word async begin',
- ' Result:=await(Crawl(c));',
- ' end;',
- ' Func:=function(c:double):word async assembler asm',
- ' end;',
- ' ']);
- ConvertProgram;
- CheckSource('TestAsync_AnonymousProc',
- LinesToStr([ // statements
- 'this.Crawl = async function (d) {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.Func = null;',
- '']),
- LinesToStr([
- '$mod.Func = async function (c) {',
- ' var Result = 0;',
- ' Result = await $mod.Crawl(c);',
- ' return Result;',
- '};',
- '$mod.Func = async function (c) {',
- '};',
- '']));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestAsync_ProcType;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- 'type',
- ' TRefFunc = reference to function(x: double = 1.3): word; async;',
- ' TFunc = function(x: double = 1.1): word; async;',
- ' TProc = procedure(x: longint = 7); async;',
- 'function Crawl(d: double): word; async;',
- 'begin',
- 'end;',
- 'procedure Run(e:longint); async;',
- 'begin',
- 'end;',
- 'procedure Fly(p: TProc); async;',
- 'begin',
- ' await(p);',
- ' await(p());',
- 'end;',
- 'var',
- ' RefFunc: TRefFunc;',
- ' Func: TFunc;',
- ' Proc, ProcB: TProc;',
- 'begin',
- ' Func:=@Crawl;',
- ' RefFunc:=@Crawl;',
- ' RefFunc:=function(c:double):word async begin',
- ' Result:=await(RefFunc);',
- ' Result:=await(RefFunc());',
- ' Result:=await(Func);',
- ' Result:=await(Func());',
- ' await(Proc);',
- ' await(Proc());',
- ' await(Proc(13));',
- ' end;',
- ' Proc:=@Run;',
- ' if Proc=ProcB then ;',
- ' ']);
- ConvertProgram;
- CheckResolverUnexpectedHints();
- CheckSource('TestAsync_ProcType',
- LinesToStr([ // statements
- 'this.Crawl = async function (d) {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.Run = async function (e) {',
- '};',
- 'this.Fly = async function (p) {',
- ' await p(7);',
- ' await p(7);',
- '};',
- 'this.RefFunc = null;',
- 'this.Func = null;',
- 'this.Proc = null;',
- 'this.ProcB = null;',
- '']),
- LinesToStr([
- '$mod.Func = $mod.Crawl;',
- '$mod.RefFunc = $mod.Crawl;',
- '$mod.RefFunc = async function (c) {',
- ' var Result = 0;',
- ' Result = await $mod.RefFunc(1.3);',
- ' Result = await $mod.RefFunc(1.3);',
- ' Result = await $mod.Func(1.1);',
- ' Result = await $mod.Func(1.1);',
- ' await $mod.Proc(7);',
- ' await $mod.Proc(7);',
- ' await $mod.Proc(13);',
- ' return Result;',
- '};',
- '$mod.Proc = $mod.Run;',
- 'if (rtl.eqCallback($mod.Proc, $mod.ProcB)) ;',
- '']));
- end;
- procedure TTestModule.TestAsync_ProcTypeAsyncModMismatchFail;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- 'type',
- ' TRefFunc = reference to function(x: double = 1.3): word;',
- 'function Crawl(d: double): word; async;',
- 'begin',
- 'end;',
- 'var',
- ' RefFunc: TRefFunc;',
- 'begin',
- ' RefFunc:=@Crawl;',
- ' ']);
- SetExpectedPasResolverError('procedure type modifier "async" mismatch',nXModifierMismatchY);
- ConvertProgram;
- end;
- procedure TTestModule.TestAsync_Inherited;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' TObject = class',
- ' function Run(w: word = 3): word; async; virtual;',
- ' end;',
- ' TBird = class',
- ' function Run(w: word = 3): word; async; override;',
- ' end;',
- 'function TObject.Run(w: word = 3): word; async;',
- 'begin',
- 'end;',
- 'function TBird.Run(w: word = 3): word;', // async modifier not needed in impl
- 'var p: TJSPromise;',
- 'begin',
- ' p:=inherited;',
- ' p:=inherited Run;',
- ' p:=inherited Run();',
- ' p:=inherited Run(4);',
- ' exit(p);',
- ' exit(inherited);',
- ' exit(inherited Run);',
- ' exit(inherited Run(5));',
- ' exit(6);',
- 'end;',
- 'begin',
- ' ']);
- ConvertProgram;
- CheckSource('TestAsync_Inherited',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Run = async function (w) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Run = async function (w) {',
- ' var Result = 0;',
- ' var p = null;',
- ' p = $mod.TObject.Run.apply(this, arguments);',
- ' p = $mod.TObject.Run.call(this, 3);',
- ' p = $mod.TObject.Run.call(this, 3);',
- ' p = $mod.TObject.Run.call(this, 4);',
- ' return p;',
- ' return $mod.TObject.Run.apply(this, arguments);',
- ' return $mod.TObject.Run.call(this, 3);',
- ' return $mod.TObject.Run.call(this, 5);',
- ' return 6;',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([
- '']));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestAsync_ClassInterface;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- 'function Say(i: IUnknown): IUnknown; async;',
- 'begin',
- 'end;',
- 'function Run: IUnknown; async;',
- 'begin',
- ' Result:=await(Run);',
- ' Result:=await(Run());',
- ' Result:=await(Run) as IUnknown;',
- ' Result:=await(Say(nil));',
- ' Result:=await(Say(await(Run())));',
- ' Result:=await(Say(await(Run()) as IUnknown));',
- ' Result:=await(Say(await(Run()) as IUnknown)) as IUnknown;',
- 'end;',
- 'procedure Fly;',
- 'var p: TJSPromise;',
- 'begin',
- ' Run;',
- ' Run();',
- ' p:=Run;',
- ' p:=Run();',
- 'end;',
- 'begin',
- ' ']);
- ConvertProgram;
- CheckSource('TestAsync_ClassInterface',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
- 'this.Say = async function (i) {',
- ' var Result = null;',
- ' return Result;',
- '};',
- 'this.Run = async function () {',
- ' var Result = null;',
- ' var $ok = false;',
- ' try {',
- ' Result = rtl.setIntfL(Result, await $mod.Run());',
- ' Result = rtl.setIntfL(Result, await $mod.Run());',
- ' Result = rtl.setIntfL(Result, rtl.intfAsIntfT(await $mod.Run(), $mod.IUnknown));',
- ' Result = rtl.setIntfL(Result, await $mod.Say(null));',
- ' Result = rtl.setIntfL(Result, await $mod.Say(await $mod.Run()));',
- ' Result = rtl.setIntfL(Result, await $mod.Say(rtl.intfAsIntfT(await $mod.Run(), $mod.IUnknown)));',
- ' Result = rtl.setIntfL(Result, rtl.intfAsIntfT(await $mod.Say(rtl.intfAsIntfT(await $mod.Run(), $mod.IUnknown)), $mod.IUnknown));',
- ' $ok = true;',
- ' } finally {',
- ' if (!$ok) rtl._Release(Result);',
- ' };',
- ' return Result;',
- '};',
- 'this.Fly = function () {',
- ' var p = null;',
- ' $mod.Run();',
- ' $mod.Run();',
- ' p = $mod.Run();',
- ' p = $mod.Run();',
- '};',
- '']),
- LinesToStr([
- '']));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestAsync_ClassInterface_AsyncMissmatchFail;
- begin
- StartProgram(true,[supTInterfacedObject]);
- Add([
- '{$mode objfpc}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' IBird = interface',
- ' procedure Run;',
- ' end;',
- ' TBird = class(TInterfacedObject,IBird)',
- ' procedure Run; async;',
- ' end;',
- 'procedure TBird.Run;',
- 'begin',
- 'end;',
- 'begin',
- ' ']);
- SetExpectedPasResolverError('procedure type modifier "async" mismatch',nXModifierMismatchY);
- ConvertProgram;
- end;
- Initialization
- RegisterTests([TTestModule]);
- end.
|
