| 1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196619761986199620062016202620362046205620662076208620962106211621262136214621562166217621862196220622162226223622462256226622762286229623062316232623362346235623662376238623962406241624262436244624562466247624862496250625162526253625462556256625762586259626062616262626362646265626662676268626962706271627262736274627562766277627862796280628162826283628462856286628762886289629062916292629362946295629662976298629963006301630263036304630563066307630863096310631163126313631463156316631763186319632063216322632363246325632663276328632963306331633263336334633563366337633863396340634163426343634463456346634763486349635063516352635363546355635663576358635963606361636263636364636563666367636863696370637163726373637463756376637763786379638063816382638363846385638663876388638963906391639263936394639563966397639863996400640164026403640464056406640764086409641064116412641364146415641664176418641964206421642264236424642564266427642864296430643164326433643464356436643764386439644064416442644364446445644664476448644964506451645264536454645564566457645864596460646164626463646464656466646764686469647064716472647364746475647664776478647964806481648264836484648564866487648864896490649164926493649464956496649764986499650065016502650365046505650665076508650965106511651265136514651565166517651865196520652165226523652465256526652765286529653065316532653365346535653665376538653965406541654265436544654565466547654865496550655165526553655465556556655765586559656065616562656365646565656665676568656965706571657265736574657565766577657865796580658165826583658465856586658765886589659065916592659365946595659665976598659966006601660266036604660566066607660866096610661166126613661466156616661766186619662066216622662366246625662666276628662966306631663266336634663566366637663866396640664166426643664466456646664766486649665066516652665366546655665666576658665966606661666266636664666566666667666866696670667166726673667466756676667766786679668066816682668366846685668666876688668966906691669266936694669566966697669866996700670167026703670467056706670767086709671067116712671367146715671667176718671967206721672267236724672567266727672867296730673167326733673467356736673767386739674067416742674367446745674667476748674967506751675267536754675567566757675867596760676167626763676467656766676767686769677067716772677367746775677667776778677967806781678267836784678567866787678867896790679167926793679467956796679767986799680068016802680368046805680668076808680968106811681268136814681568166817681868196820682168226823682468256826682768286829683068316832683368346835683668376838683968406841684268436844684568466847684868496850685168526853685468556856685768586859686068616862686368646865686668676868686968706871687268736874687568766877687868796880688168826883688468856886688768886889689068916892689368946895689668976898689969006901690269036904690569066907690869096910691169126913691469156916691769186919692069216922692369246925692669276928692969306931693269336934693569366937693869396940694169426943694469456946694769486949695069516952695369546955695669576958695969606961696269636964696569666967696869696970697169726973697469756976697769786979698069816982698369846985698669876988698969906991699269936994699569966997699869997000700170027003700470057006700770087009701070117012701370147015701670177018701970207021702270237024702570267027702870297030703170327033703470357036703770387039704070417042704370447045704670477048704970507051705270537054705570567057705870597060706170627063706470657066706770687069707070717072707370747075707670777078707970807081708270837084708570867087708870897090709170927093709470957096709770987099710071017102710371047105710671077108710971107111711271137114711571167117711871197120712171227123712471257126712771287129713071317132713371347135713671377138713971407141714271437144714571467147714871497150715171527153715471557156715771587159716071617162716371647165716671677168716971707171717271737174717571767177717871797180718171827183718471857186718771887189719071917192719371947195719671977198719972007201720272037204720572067207720872097210721172127213721472157216721772187219722072217222722372247225722672277228722972307231723272337234723572367237723872397240724172427243724472457246724772487249725072517252725372547255725672577258725972607261726272637264726572667267726872697270727172727273727472757276727772787279728072817282728372847285728672877288728972907291729272937294729572967297729872997300730173027303730473057306730773087309731073117312731373147315731673177318731973207321732273237324732573267327732873297330733173327333733473357336733773387339734073417342734373447345734673477348734973507351735273537354735573567357735873597360736173627363736473657366736773687369737073717372737373747375737673777378737973807381738273837384738573867387738873897390739173927393739473957396739773987399740074017402740374047405740674077408740974107411741274137414741574167417741874197420742174227423742474257426742774287429743074317432743374347435743674377438743974407441744274437444744574467447744874497450745174527453745474557456745774587459746074617462746374647465746674677468746974707471747274737474747574767477747874797480748174827483748474857486748774887489749074917492749374947495749674977498749975007501750275037504750575067507750875097510751175127513751475157516751775187519752075217522752375247525752675277528752975307531753275337534753575367537753875397540754175427543754475457546754775487549755075517552755375547555755675577558755975607561756275637564756575667567756875697570757175727573757475757576757775787579758075817582758375847585758675877588758975907591759275937594759575967597759875997600760176027603760476057606760776087609761076117612761376147615761676177618761976207621762276237624762576267627762876297630763176327633763476357636763776387639764076417642764376447645764676477648764976507651765276537654765576567657765876597660766176627663766476657666766776687669767076717672767376747675767676777678767976807681768276837684768576867687768876897690769176927693769476957696769776987699770077017702770377047705770677077708770977107711771277137714771577167717771877197720772177227723772477257726772777287729773077317732773377347735773677377738773977407741774277437744774577467747774877497750775177527753775477557756775777587759776077617762776377647765776677677768776977707771777277737774777577767777777877797780778177827783778477857786778777887789779077917792779377947795779677977798779978007801780278037804780578067807780878097810781178127813781478157816781778187819782078217822782378247825782678277828782978307831783278337834783578367837783878397840784178427843784478457846784778487849785078517852785378547855785678577858785978607861786278637864786578667867786878697870787178727873787478757876787778787879788078817882788378847885788678877888788978907891789278937894789578967897789878997900790179027903790479057906790779087909791079117912791379147915791679177918791979207921792279237924792579267927792879297930793179327933793479357936793779387939794079417942794379447945794679477948794979507951795279537954795579567957795879597960796179627963796479657966796779687969797079717972797379747975797679777978797979807981798279837984798579867987798879897990799179927993799479957996799779987999800080018002800380048005800680078008800980108011801280138014801580168017801880198020802180228023802480258026802780288029803080318032803380348035803680378038803980408041804280438044804580468047804880498050805180528053805480558056805780588059806080618062806380648065806680678068806980708071807280738074807580768077807880798080808180828083808480858086808780888089809080918092809380948095809680978098809981008101810281038104810581068107810881098110811181128113811481158116811781188119812081218122812381248125812681278128812981308131813281338134813581368137813881398140814181428143814481458146814781488149815081518152815381548155815681578158815981608161816281638164816581668167816881698170817181728173817481758176817781788179818081818182818381848185818681878188818981908191819281938194819581968197819881998200820182028203820482058206820782088209821082118212821382148215821682178218821982208221822282238224822582268227822882298230823182328233823482358236823782388239824082418242824382448245824682478248824982508251825282538254825582568257825882598260826182628263826482658266826782688269827082718272827382748275827682778278827982808281828282838284828582868287828882898290829182928293829482958296829782988299830083018302830383048305830683078308830983108311831283138314831583168317831883198320832183228323832483258326832783288329833083318332833383348335833683378338833983408341834283438344834583468347834883498350835183528353835483558356835783588359836083618362836383648365836683678368836983708371837283738374837583768377837883798380838183828383838483858386838783888389839083918392839383948395839683978398839984008401840284038404840584068407840884098410841184128413841484158416841784188419842084218422842384248425842684278428842984308431843284338434843584368437843884398440844184428443844484458446844784488449845084518452845384548455845684578458845984608461846284638464846584668467846884698470847184728473847484758476847784788479848084818482848384848485848684878488848984908491849284938494849584968497849884998500850185028503850485058506850785088509851085118512851385148515851685178518851985208521852285238524852585268527852885298530853185328533853485358536853785388539854085418542854385448545854685478548854985508551855285538554855585568557855885598560856185628563856485658566856785688569857085718572857385748575857685778578857985808581858285838584858585868587858885898590859185928593859485958596859785988599860086018602860386048605860686078608860986108611861286138614861586168617861886198620862186228623862486258626862786288629863086318632863386348635863686378638863986408641864286438644864586468647864886498650865186528653865486558656865786588659866086618662866386648665866686678668866986708671867286738674867586768677867886798680868186828683868486858686868786888689869086918692869386948695869686978698869987008701870287038704870587068707870887098710871187128713871487158716871787188719872087218722872387248725872687278728872987308731873287338734873587368737873887398740874187428743874487458746874787488749875087518752875387548755875687578758875987608761876287638764876587668767876887698770877187728773877487758776877787788779878087818782878387848785878687878788878987908791879287938794879587968797879887998800880188028803880488058806880788088809881088118812881388148815881688178818881988208821882288238824882588268827882888298830883188328833883488358836883788388839884088418842884388448845884688478848884988508851885288538854885588568857885888598860886188628863886488658866886788688869887088718872887388748875887688778878887988808881888288838884888588868887888888898890889188928893889488958896889788988899890089018902890389048905890689078908890989108911891289138914891589168917891889198920892189228923892489258926892789288929893089318932893389348935893689378938893989408941894289438944894589468947894889498950895189528953895489558956895789588959896089618962896389648965896689678968896989708971897289738974897589768977897889798980898189828983898489858986898789888989899089918992899389948995899689978998899990009001900290039004900590069007900890099010901190129013901490159016901790189019902090219022902390249025902690279028902990309031903290339034903590369037903890399040904190429043904490459046904790489049905090519052905390549055905690579058905990609061906290639064906590669067906890699070907190729073907490759076907790789079908090819082908390849085908690879088908990909091909290939094909590969097909890999100910191029103910491059106910791089109911091119112911391149115911691179118911991209121912291239124912591269127912891299130913191329133913491359136913791389139914091419142914391449145914691479148914991509151915291539154915591569157915891599160916191629163916491659166916791689169917091719172917391749175917691779178917991809181918291839184918591869187918891899190919191929193919491959196919791989199920092019202920392049205920692079208920992109211921292139214921592169217921892199220922192229223922492259226922792289229923092319232923392349235923692379238923992409241924292439244924592469247924892499250925192529253925492559256925792589259926092619262926392649265926692679268926992709271927292739274927592769277927892799280928192829283928492859286928792889289929092919292929392949295929692979298929993009301930293039304930593069307930893099310931193129313931493159316931793189319932093219322932393249325932693279328932993309331933293339334933593369337933893399340934193429343934493459346934793489349935093519352935393549355935693579358935993609361936293639364936593669367936893699370937193729373937493759376937793789379938093819382938393849385938693879388938993909391939293939394939593969397939893999400940194029403940494059406940794089409941094119412941394149415941694179418941994209421942294239424942594269427942894299430943194329433943494359436943794389439944094419442944394449445944694479448944994509451945294539454945594569457945894599460946194629463946494659466946794689469947094719472947394749475947694779478947994809481948294839484948594869487948894899490949194929493949494959496949794989499950095019502950395049505950695079508950995109511951295139514951595169517951895199520952195229523952495259526952795289529953095319532953395349535953695379538953995409541954295439544954595469547954895499550955195529553955495559556955795589559956095619562956395649565956695679568956995709571957295739574957595769577957895799580958195829583958495859586958795889589959095919592959395949595959695979598959996009601960296039604960596069607960896099610961196129613961496159616961796189619962096219622962396249625962696279628962996309631963296339634963596369637963896399640964196429643964496459646964796489649965096519652965396549655965696579658965996609661966296639664966596669667966896699670967196729673967496759676967796789679968096819682968396849685968696879688968996909691969296939694969596969697969896999700970197029703970497059706970797089709971097119712971397149715971697179718971997209721972297239724972597269727972897299730973197329733973497359736973797389739974097419742974397449745974697479748974997509751975297539754975597569757975897599760976197629763976497659766976797689769977097719772977397749775977697779778977997809781978297839784978597869787978897899790979197929793979497959796979797989799980098019802980398049805980698079808980998109811981298139814981598169817981898199820982198229823982498259826982798289829983098319832983398349835983698379838983998409841984298439844984598469847984898499850985198529853985498559856985798589859986098619862986398649865986698679868986998709871987298739874987598769877987898799880988198829883988498859886988798889889989098919892989398949895989698979898989999009901990299039904990599069907990899099910991199129913991499159916991799189919992099219922992399249925992699279928992999309931993299339934993599369937993899399940994199429943994499459946994799489949995099519952995399549955995699579958995999609961996299639964996599669967996899699970997199729973997499759976997799789979998099819982998399849985998699879988998999909991999299939994999599969997999899991000010001100021000310004100051000610007100081000910010100111001210013100141001510016100171001810019100201002110022100231002410025100261002710028100291003010031100321003310034100351003610037100381003910040100411004210043100441004510046100471004810049100501005110052100531005410055100561005710058100591006010061100621006310064100651006610067100681006910070100711007210073100741007510076100771007810079100801008110082100831008410085100861008710088100891009010091100921009310094100951009610097100981009910100101011010210103101041010510106101071010810109101101011110112101131011410115101161011710118101191012010121101221012310124101251012610127101281012910130101311013210133101341013510136101371013810139101401014110142101431014410145101461014710148101491015010151101521015310154101551015610157101581015910160101611016210163101641016510166101671016810169101701017110172101731017410175101761017710178101791018010181101821018310184101851018610187101881018910190101911019210193101941019510196101971019810199102001020110202102031020410205102061020710208102091021010211102121021310214102151021610217102181021910220102211022210223102241022510226102271022810229102301023110232102331023410235102361023710238102391024010241102421024310244102451024610247102481024910250102511025210253102541025510256102571025810259102601026110262102631026410265102661026710268102691027010271102721027310274102751027610277102781027910280102811028210283102841028510286102871028810289102901029110292102931029410295102961029710298102991030010301103021030310304103051030610307103081030910310103111031210313103141031510316103171031810319103201032110322103231032410325103261032710328103291033010331103321033310334103351033610337103381033910340103411034210343103441034510346103471034810349103501035110352103531035410355103561035710358103591036010361103621036310364103651036610367103681036910370103711037210373103741037510376103771037810379103801038110382103831038410385103861038710388103891039010391103921039310394103951039610397103981039910400104011040210403104041040510406104071040810409104101041110412104131041410415104161041710418104191042010421104221042310424104251042610427104281042910430104311043210433104341043510436104371043810439104401044110442104431044410445104461044710448104491045010451104521045310454104551045610457104581045910460104611046210463104641046510466104671046810469104701047110472104731047410475104761047710478104791048010481104821048310484104851048610487104881048910490104911049210493104941049510496104971049810499105001050110502105031050410505105061050710508105091051010511105121051310514105151051610517105181051910520105211052210523105241052510526105271052810529105301053110532105331053410535105361053710538105391054010541105421054310544105451054610547105481054910550105511055210553105541055510556105571055810559105601056110562105631056410565105661056710568105691057010571105721057310574105751057610577105781057910580105811058210583105841058510586105871058810589105901059110592105931059410595105961059710598105991060010601106021060310604106051060610607106081060910610106111061210613106141061510616106171061810619106201062110622106231062410625106261062710628106291063010631106321063310634106351063610637106381063910640106411064210643106441064510646106471064810649106501065110652106531065410655106561065710658106591066010661106621066310664106651066610667106681066910670106711067210673106741067510676106771067810679106801068110682106831068410685106861068710688106891069010691106921069310694106951069610697106981069910700107011070210703107041070510706107071070810709107101071110712107131071410715107161071710718107191072010721107221072310724107251072610727107281072910730107311073210733107341073510736107371073810739107401074110742107431074410745107461074710748107491075010751107521075310754107551075610757107581075910760107611076210763107641076510766107671076810769107701077110772107731077410775107761077710778107791078010781107821078310784107851078610787107881078910790107911079210793107941079510796107971079810799108001080110802108031080410805108061080710808108091081010811108121081310814108151081610817108181081910820108211082210823108241082510826108271082810829108301083110832108331083410835108361083710838108391084010841108421084310844108451084610847108481084910850108511085210853108541085510856108571085810859108601086110862108631086410865108661086710868108691087010871108721087310874108751087610877108781087910880108811088210883108841088510886108871088810889108901089110892108931089410895108961089710898108991090010901109021090310904109051090610907109081090910910109111091210913109141091510916109171091810919109201092110922109231092410925109261092710928109291093010931109321093310934109351093610937109381093910940109411094210943109441094510946109471094810949109501095110952109531095410955109561095710958109591096010961109621096310964109651096610967109681096910970109711097210973109741097510976109771097810979109801098110982109831098410985109861098710988109891099010991109921099310994109951099610997109981099911000110011100211003110041100511006110071100811009110101101111012110131101411015110161101711018110191102011021110221102311024110251102611027110281102911030110311103211033110341103511036110371103811039110401104111042110431104411045110461104711048110491105011051110521105311054110551105611057110581105911060110611106211063110641106511066110671106811069110701107111072110731107411075110761107711078110791108011081110821108311084110851108611087110881108911090110911109211093110941109511096110971109811099111001110111102111031110411105111061110711108111091111011111111121111311114111151111611117111181111911120111211112211123111241112511126111271112811129111301113111132111331113411135111361113711138111391114011141111421114311144111451114611147111481114911150111511115211153111541115511156111571115811159111601116111162111631116411165111661116711168111691117011171111721117311174111751117611177111781117911180111811118211183111841118511186111871118811189111901119111192111931119411195111961119711198111991120011201112021120311204112051120611207112081120911210112111121211213112141121511216112171121811219112201122111222112231122411225112261122711228112291123011231112321123311234112351123611237112381123911240112411124211243112441124511246112471124811249112501125111252112531125411255112561125711258112591126011261112621126311264112651126611267112681126911270112711127211273112741127511276112771127811279112801128111282112831128411285112861128711288112891129011291112921129311294112951129611297112981129911300113011130211303113041130511306113071130811309113101131111312113131131411315113161131711318113191132011321113221132311324113251132611327113281132911330113311133211333113341133511336113371133811339113401134111342113431134411345113461134711348113491135011351113521135311354113551135611357113581135911360113611136211363113641136511366113671136811369113701137111372113731137411375113761137711378113791138011381113821138311384113851138611387113881138911390113911139211393113941139511396113971139811399114001140111402114031140411405114061140711408114091141011411114121141311414114151141611417114181141911420114211142211423114241142511426114271142811429114301143111432114331143411435114361143711438114391144011441114421144311444114451144611447114481144911450114511145211453114541145511456114571145811459114601146111462114631146411465114661146711468114691147011471114721147311474114751147611477114781147911480114811148211483114841148511486114871148811489114901149111492114931149411495114961149711498114991150011501115021150311504115051150611507115081150911510115111151211513115141151511516115171151811519115201152111522115231152411525115261152711528115291153011531115321153311534115351153611537115381153911540115411154211543115441154511546115471154811549115501155111552115531155411555115561155711558115591156011561115621156311564115651156611567115681156911570115711157211573115741157511576115771157811579115801158111582115831158411585115861158711588115891159011591115921159311594115951159611597115981159911600116011160211603116041160511606116071160811609116101161111612116131161411615116161161711618116191162011621116221162311624116251162611627116281162911630116311163211633116341163511636116371163811639116401164111642116431164411645116461164711648116491165011651116521165311654116551165611657116581165911660116611166211663116641166511666116671166811669116701167111672116731167411675116761167711678116791168011681116821168311684116851168611687116881168911690116911169211693116941169511696116971169811699117001170111702117031170411705117061170711708117091171011711117121171311714117151171611717117181171911720117211172211723117241172511726117271172811729117301173111732117331173411735117361173711738117391174011741117421174311744117451174611747117481174911750117511175211753117541175511756117571175811759117601176111762117631176411765117661176711768117691177011771117721177311774117751177611777117781177911780117811178211783117841178511786117871178811789117901179111792117931179411795117961179711798117991180011801118021180311804118051180611807118081180911810118111181211813118141181511816118171181811819118201182111822118231182411825118261182711828118291183011831118321183311834118351183611837118381183911840118411184211843118441184511846118471184811849118501185111852118531185411855118561185711858118591186011861118621186311864118651186611867118681186911870118711187211873118741187511876118771187811879118801188111882118831188411885118861188711888118891189011891118921189311894118951189611897118981189911900119011190211903119041190511906119071190811909119101191111912119131191411915119161191711918119191192011921119221192311924119251192611927119281192911930119311193211933119341193511936119371193811939119401194111942119431194411945119461194711948119491195011951119521195311954119551195611957119581195911960119611196211963119641196511966119671196811969119701197111972119731197411975119761197711978119791198011981119821198311984119851198611987119881198911990119911199211993119941199511996119971199811999120001200112002120031200412005120061200712008120091201012011120121201312014120151201612017120181201912020120211202212023120241202512026120271202812029120301203112032120331203412035120361203712038120391204012041120421204312044120451204612047120481204912050120511205212053120541205512056120571205812059120601206112062120631206412065120661206712068120691207012071120721207312074120751207612077120781207912080120811208212083120841208512086120871208812089120901209112092120931209412095120961209712098120991210012101121021210312104121051210612107121081210912110121111211212113121141211512116121171211812119121201212112122121231212412125121261212712128121291213012131121321213312134121351213612137121381213912140121411214212143121441214512146121471214812149121501215112152121531215412155121561215712158121591216012161121621216312164121651216612167121681216912170121711217212173121741217512176121771217812179121801218112182121831218412185121861218712188121891219012191121921219312194121951219612197121981219912200122011220212203122041220512206122071220812209122101221112212122131221412215122161221712218122191222012221122221222312224122251222612227122281222912230122311223212233122341223512236122371223812239122401224112242122431224412245122461224712248122491225012251122521225312254122551225612257122581225912260122611226212263122641226512266122671226812269122701227112272122731227412275122761227712278122791228012281122821228312284122851228612287122881228912290122911229212293122941229512296122971229812299123001230112302123031230412305123061230712308123091231012311123121231312314123151231612317123181231912320123211232212323123241232512326123271232812329123301233112332123331233412335123361233712338123391234012341123421234312344123451234612347123481234912350123511235212353123541235512356123571235812359123601236112362123631236412365123661236712368123691237012371123721237312374123751237612377123781237912380123811238212383123841238512386123871238812389123901239112392123931239412395123961239712398123991240012401124021240312404124051240612407124081240912410124111241212413124141241512416124171241812419124201242112422124231242412425124261242712428124291243012431124321243312434124351243612437124381243912440124411244212443124441244512446124471244812449124501245112452124531245412455124561245712458124591246012461124621246312464124651246612467124681246912470124711247212473124741247512476124771247812479124801248112482124831248412485124861248712488124891249012491124921249312494124951249612497124981249912500125011250212503125041250512506125071250812509125101251112512125131251412515125161251712518125191252012521125221252312524125251252612527125281252912530125311253212533125341253512536125371253812539125401254112542125431254412545125461254712548125491255012551125521255312554125551255612557125581255912560125611256212563125641256512566125671256812569125701257112572125731257412575125761257712578125791258012581125821258312584125851258612587125881258912590125911259212593125941259512596125971259812599126001260112602126031260412605126061260712608126091261012611126121261312614126151261612617126181261912620126211262212623126241262512626126271262812629126301263112632126331263412635126361263712638126391264012641126421264312644126451264612647126481264912650126511265212653126541265512656126571265812659126601266112662126631266412665126661266712668126691267012671126721267312674126751267612677126781267912680126811268212683126841268512686126871268812689126901269112692126931269412695126961269712698126991270012701127021270312704127051270612707127081270912710127111271212713127141271512716127171271812719127201272112722127231272412725127261272712728127291273012731127321273312734127351273612737127381273912740127411274212743127441274512746127471274812749127501275112752127531275412755127561275712758127591276012761127621276312764127651276612767127681276912770127711277212773127741277512776127771277812779127801278112782127831278412785127861278712788127891279012791127921279312794127951279612797127981279912800128011280212803128041280512806128071280812809128101281112812128131281412815128161281712818128191282012821128221282312824128251282612827128281282912830128311283212833128341283512836128371283812839128401284112842128431284412845128461284712848128491285012851128521285312854128551285612857128581285912860128611286212863128641286512866128671286812869128701287112872128731287412875128761287712878128791288012881128821288312884128851288612887128881288912890128911289212893128941289512896128971289812899129001290112902129031290412905129061290712908129091291012911129121291312914129151291612917129181291912920129211292212923129241292512926129271292812929129301293112932129331293412935129361293712938129391294012941129421294312944129451294612947129481294912950129511295212953129541295512956129571295812959129601296112962129631296412965129661296712968129691297012971129721297312974129751297612977129781297912980129811298212983129841298512986129871298812989129901299112992129931299412995129961299712998129991300013001130021300313004130051300613007130081300913010130111301213013130141301513016130171301813019130201302113022130231302413025130261302713028130291303013031130321303313034130351303613037130381303913040130411304213043130441304513046130471304813049130501305113052130531305413055130561305713058130591306013061130621306313064130651306613067130681306913070130711307213073130741307513076130771307813079130801308113082130831308413085130861308713088130891309013091130921309313094130951309613097130981309913100131011310213103131041310513106131071310813109131101311113112131131311413115131161311713118131191312013121131221312313124131251312613127131281312913130131311313213133131341313513136131371313813139131401314113142131431314413145131461314713148131491315013151131521315313154131551315613157131581315913160131611316213163131641316513166131671316813169131701317113172131731317413175131761317713178131791318013181131821318313184131851318613187131881318913190131911319213193131941319513196131971319813199132001320113202132031320413205132061320713208132091321013211132121321313214132151321613217132181321913220132211322213223132241322513226132271322813229132301323113232132331323413235132361323713238132391324013241132421324313244132451324613247132481324913250132511325213253132541325513256132571325813259132601326113262132631326413265132661326713268132691327013271132721327313274132751327613277132781327913280132811328213283132841328513286132871328813289132901329113292132931329413295132961329713298132991330013301133021330313304133051330613307133081330913310133111331213313133141331513316133171331813319133201332113322133231332413325133261332713328133291333013331133321333313334133351333613337133381333913340133411334213343133441334513346133471334813349133501335113352133531335413355133561335713358133591336013361133621336313364133651336613367133681336913370133711337213373133741337513376133771337813379133801338113382133831338413385133861338713388133891339013391133921339313394133951339613397133981339913400134011340213403134041340513406134071340813409134101341113412134131341413415134161341713418134191342013421134221342313424134251342613427134281342913430134311343213433134341343513436134371343813439134401344113442134431344413445134461344713448134491345013451134521345313454134551345613457134581345913460134611346213463134641346513466134671346813469134701347113472134731347413475134761347713478134791348013481134821348313484134851348613487134881348913490134911349213493134941349513496134971349813499135001350113502135031350413505135061350713508135091351013511135121351313514135151351613517135181351913520135211352213523135241352513526135271352813529135301353113532135331353413535135361353713538135391354013541135421354313544135451354613547135481354913550135511355213553135541355513556135571355813559135601356113562135631356413565135661356713568135691357013571135721357313574135751357613577135781357913580135811358213583135841358513586135871358813589135901359113592135931359413595135961359713598135991360013601136021360313604136051360613607136081360913610136111361213613136141361513616136171361813619136201362113622136231362413625136261362713628136291363013631136321363313634136351363613637136381363913640136411364213643136441364513646136471364813649136501365113652136531365413655136561365713658136591366013661136621366313664136651366613667136681366913670136711367213673136741367513676136771367813679136801368113682136831368413685136861368713688136891369013691136921369313694136951369613697136981369913700137011370213703137041370513706137071370813709137101371113712137131371413715137161371713718137191372013721137221372313724137251372613727137281372913730137311373213733137341373513736137371373813739137401374113742137431374413745137461374713748137491375013751137521375313754137551375613757137581375913760137611376213763137641376513766137671376813769137701377113772137731377413775137761377713778137791378013781137821378313784137851378613787137881378913790137911379213793137941379513796137971379813799138001380113802138031380413805138061380713808138091381013811138121381313814138151381613817138181381913820138211382213823138241382513826138271382813829138301383113832138331383413835138361383713838138391384013841138421384313844138451384613847138481384913850138511385213853138541385513856138571385813859138601386113862138631386413865138661386713868138691387013871138721387313874138751387613877138781387913880138811388213883138841388513886138871388813889138901389113892138931389413895138961389713898138991390013901139021390313904139051390613907139081390913910139111391213913139141391513916139171391813919139201392113922139231392413925139261392713928139291393013931139321393313934139351393613937139381393913940139411394213943139441394513946139471394813949139501395113952139531395413955139561395713958139591396013961139621396313964139651396613967139681396913970139711397213973139741397513976139771397813979139801398113982139831398413985139861398713988139891399013991139921399313994139951399613997139981399914000140011400214003140041400514006140071400814009140101401114012140131401414015140161401714018140191402014021140221402314024140251402614027140281402914030140311403214033140341403514036140371403814039140401404114042140431404414045140461404714048140491405014051140521405314054140551405614057140581405914060140611406214063140641406514066140671406814069140701407114072140731407414075140761407714078140791408014081140821408314084140851408614087140881408914090140911409214093140941409514096140971409814099141001410114102141031410414105141061410714108141091411014111141121411314114141151411614117141181411914120141211412214123141241412514126141271412814129141301413114132141331413414135141361413714138141391414014141141421414314144141451414614147141481414914150141511415214153141541415514156141571415814159141601416114162141631416414165141661416714168141691417014171141721417314174141751417614177141781417914180141811418214183141841418514186141871418814189141901419114192141931419414195141961419714198141991420014201142021420314204142051420614207142081420914210142111421214213142141421514216142171421814219142201422114222142231422414225142261422714228142291423014231142321423314234142351423614237142381423914240142411424214243142441424514246142471424814249142501425114252142531425414255142561425714258142591426014261142621426314264142651426614267142681426914270142711427214273142741427514276142771427814279142801428114282142831428414285142861428714288142891429014291142921429314294142951429614297142981429914300143011430214303143041430514306143071430814309143101431114312143131431414315143161431714318143191432014321143221432314324143251432614327143281432914330143311433214333143341433514336143371433814339143401434114342143431434414345143461434714348143491435014351143521435314354143551435614357143581435914360143611436214363143641436514366143671436814369143701437114372143731437414375143761437714378143791438014381143821438314384143851438614387143881438914390143911439214393143941439514396143971439814399144001440114402144031440414405144061440714408144091441014411144121441314414144151441614417144181441914420144211442214423144241442514426144271442814429144301443114432144331443414435144361443714438144391444014441144421444314444144451444614447144481444914450144511445214453144541445514456144571445814459144601446114462144631446414465144661446714468144691447014471144721447314474144751447614477144781447914480144811448214483144841448514486144871448814489144901449114492144931449414495144961449714498144991450014501145021450314504145051450614507145081450914510145111451214513145141451514516145171451814519145201452114522145231452414525145261452714528145291453014531145321453314534145351453614537145381453914540145411454214543145441454514546145471454814549145501455114552145531455414555145561455714558145591456014561145621456314564145651456614567145681456914570145711457214573145741457514576145771457814579145801458114582145831458414585145861458714588145891459014591145921459314594145951459614597145981459914600146011460214603146041460514606146071460814609146101461114612146131461414615146161461714618146191462014621146221462314624146251462614627146281462914630146311463214633146341463514636146371463814639146401464114642146431464414645146461464714648146491465014651146521465314654146551465614657146581465914660146611466214663146641466514666146671466814669146701467114672146731467414675146761467714678146791468014681146821468314684146851468614687146881468914690146911469214693146941469514696146971469814699147001470114702147031470414705147061470714708147091471014711147121471314714147151471614717147181471914720147211472214723147241472514726147271472814729147301473114732147331473414735147361473714738147391474014741147421474314744147451474614747147481474914750147511475214753147541475514756147571475814759147601476114762147631476414765147661476714768147691477014771147721477314774147751477614777147781477914780147811478214783147841478514786147871478814789147901479114792147931479414795147961479714798147991480014801148021480314804148051480614807148081480914810148111481214813148141481514816148171481814819148201482114822148231482414825148261482714828148291483014831148321483314834148351483614837148381483914840148411484214843148441484514846148471484814849148501485114852148531485414855148561485714858148591486014861148621486314864148651486614867148681486914870148711487214873148741487514876148771487814879148801488114882148831488414885148861488714888148891489014891148921489314894148951489614897148981489914900149011490214903149041490514906149071490814909149101491114912149131491414915149161491714918149191492014921149221492314924149251492614927149281492914930149311493214933149341493514936149371493814939149401494114942149431494414945149461494714948149491495014951149521495314954149551495614957149581495914960149611496214963149641496514966149671496814969149701497114972149731497414975149761497714978149791498014981149821498314984149851498614987149881498914990149911499214993149941499514996149971499814999150001500115002150031500415005150061500715008150091501015011150121501315014150151501615017150181501915020150211502215023150241502515026150271502815029150301503115032150331503415035150361503715038150391504015041150421504315044150451504615047150481504915050150511505215053150541505515056150571505815059150601506115062150631506415065150661506715068150691507015071150721507315074150751507615077150781507915080150811508215083150841508515086150871508815089150901509115092150931509415095150961509715098150991510015101151021510315104151051510615107151081510915110151111511215113151141511515116151171511815119151201512115122151231512415125151261512715128151291513015131151321513315134151351513615137151381513915140151411514215143151441514515146151471514815149151501515115152151531515415155151561515715158151591516015161151621516315164151651516615167151681516915170151711517215173151741517515176151771517815179151801518115182151831518415185151861518715188151891519015191151921519315194151951519615197151981519915200152011520215203152041520515206152071520815209152101521115212152131521415215152161521715218152191522015221152221522315224152251522615227152281522915230152311523215233152341523515236152371523815239152401524115242152431524415245152461524715248152491525015251152521525315254152551525615257152581525915260152611526215263152641526515266152671526815269152701527115272152731527415275152761527715278152791528015281152821528315284152851528615287152881528915290152911529215293152941529515296152971529815299153001530115302153031530415305153061530715308153091531015311153121531315314153151531615317153181531915320153211532215323153241532515326153271532815329153301533115332153331533415335153361533715338153391534015341153421534315344153451534615347153481534915350153511535215353153541535515356153571535815359153601536115362153631536415365153661536715368153691537015371153721537315374153751537615377153781537915380153811538215383153841538515386153871538815389153901539115392153931539415395153961539715398153991540015401154021540315404154051540615407154081540915410154111541215413154141541515416154171541815419154201542115422154231542415425154261542715428154291543015431154321543315434154351543615437154381543915440154411544215443154441544515446154471544815449154501545115452154531545415455154561545715458154591546015461154621546315464154651546615467154681546915470154711547215473154741547515476154771547815479154801548115482154831548415485154861548715488154891549015491154921549315494154951549615497154981549915500155011550215503155041550515506155071550815509155101551115512155131551415515155161551715518155191552015521155221552315524155251552615527155281552915530155311553215533155341553515536155371553815539155401554115542155431554415545155461554715548155491555015551155521555315554155551555615557155581555915560155611556215563155641556515566155671556815569155701557115572155731557415575155761557715578155791558015581155821558315584155851558615587155881558915590155911559215593155941559515596155971559815599156001560115602156031560415605156061560715608156091561015611156121561315614156151561615617156181561915620156211562215623156241562515626156271562815629156301563115632156331563415635156361563715638156391564015641156421564315644156451564615647156481564915650156511565215653156541565515656156571565815659156601566115662156631566415665156661566715668156691567015671156721567315674156751567615677156781567915680156811568215683156841568515686156871568815689156901569115692156931569415695156961569715698156991570015701157021570315704157051570615707157081570915710157111571215713157141571515716157171571815719157201572115722157231572415725157261572715728157291573015731157321573315734157351573615737157381573915740157411574215743157441574515746157471574815749157501575115752157531575415755157561575715758157591576015761157621576315764157651576615767157681576915770157711577215773157741577515776157771577815779157801578115782157831578415785157861578715788157891579015791157921579315794157951579615797157981579915800158011580215803158041580515806158071580815809158101581115812158131581415815158161581715818158191582015821158221582315824158251582615827158281582915830158311583215833158341583515836158371583815839158401584115842158431584415845158461584715848158491585015851158521585315854158551585615857158581585915860158611586215863158641586515866158671586815869158701587115872158731587415875158761587715878158791588015881158821588315884158851588615887158881588915890158911589215893158941589515896158971589815899159001590115902159031590415905159061590715908159091591015911159121591315914159151591615917159181591915920159211592215923159241592515926159271592815929159301593115932159331593415935159361593715938159391594015941159421594315944159451594615947159481594915950159511595215953159541595515956159571595815959159601596115962159631596415965159661596715968159691597015971159721597315974159751597615977159781597915980159811598215983159841598515986159871598815989159901599115992159931599415995159961599715998159991600016001160021600316004160051600616007160081600916010160111601216013160141601516016160171601816019160201602116022160231602416025160261602716028160291603016031160321603316034160351603616037160381603916040160411604216043160441604516046160471604816049160501605116052160531605416055160561605716058160591606016061160621606316064160651606616067160681606916070160711607216073160741607516076160771607816079160801608116082160831608416085160861608716088160891609016091160921609316094160951609616097160981609916100161011610216103161041610516106161071610816109161101611116112161131611416115161161611716118161191612016121161221612316124161251612616127161281612916130161311613216133161341613516136161371613816139161401614116142161431614416145161461614716148161491615016151161521615316154161551615616157161581615916160161611616216163161641616516166161671616816169161701617116172161731617416175161761617716178161791618016181161821618316184161851618616187161881618916190161911619216193161941619516196161971619816199162001620116202162031620416205162061620716208162091621016211162121621316214162151621616217162181621916220162211622216223162241622516226162271622816229162301623116232162331623416235162361623716238162391624016241162421624316244162451624616247162481624916250162511625216253162541625516256162571625816259162601626116262162631626416265162661626716268162691627016271162721627316274162751627616277162781627916280162811628216283162841628516286162871628816289162901629116292162931629416295162961629716298162991630016301163021630316304163051630616307163081630916310163111631216313163141631516316163171631816319163201632116322163231632416325163261632716328163291633016331163321633316334163351633616337163381633916340163411634216343163441634516346163471634816349163501635116352163531635416355163561635716358163591636016361163621636316364163651636616367163681636916370163711637216373163741637516376163771637816379163801638116382163831638416385163861638716388163891639016391163921639316394163951639616397163981639916400164011640216403164041640516406164071640816409164101641116412164131641416415164161641716418164191642016421164221642316424164251642616427164281642916430164311643216433164341643516436164371643816439164401644116442164431644416445164461644716448164491645016451164521645316454164551645616457164581645916460164611646216463164641646516466164671646816469164701647116472164731647416475164761647716478164791648016481164821648316484164851648616487164881648916490164911649216493164941649516496164971649816499165001650116502165031650416505165061650716508165091651016511165121651316514165151651616517165181651916520165211652216523165241652516526165271652816529165301653116532165331653416535165361653716538165391654016541165421654316544165451654616547165481654916550165511655216553165541655516556165571655816559165601656116562165631656416565165661656716568165691657016571165721657316574165751657616577165781657916580165811658216583165841658516586165871658816589165901659116592165931659416595165961659716598165991660016601166021660316604166051660616607166081660916610166111661216613166141661516616166171661816619166201662116622166231662416625166261662716628166291663016631166321663316634166351663616637166381663916640166411664216643166441664516646166471664816649166501665116652166531665416655166561665716658166591666016661166621666316664166651666616667166681666916670166711667216673166741667516676166771667816679166801668116682166831668416685166861668716688166891669016691166921669316694166951669616697166981669916700167011670216703167041670516706167071670816709167101671116712167131671416715167161671716718167191672016721167221672316724167251672616727167281672916730167311673216733167341673516736167371673816739167401674116742167431674416745167461674716748167491675016751167521675316754167551675616757167581675916760167611676216763167641676516766167671676816769167701677116772167731677416775167761677716778167791678016781167821678316784167851678616787167881678916790167911679216793167941679516796167971679816799168001680116802168031680416805168061680716808168091681016811168121681316814168151681616817168181681916820168211682216823168241682516826168271682816829168301683116832168331683416835168361683716838168391684016841168421684316844168451684616847168481684916850168511685216853168541685516856168571685816859168601686116862168631686416865168661686716868168691687016871168721687316874168751687616877168781687916880168811688216883168841688516886168871688816889168901689116892168931689416895168961689716898168991690016901169021690316904169051690616907169081690916910169111691216913169141691516916169171691816919169201692116922169231692416925169261692716928169291693016931169321693316934169351693616937169381693916940169411694216943169441694516946169471694816949169501695116952169531695416955169561695716958169591696016961169621696316964169651696616967169681696916970169711697216973169741697516976169771697816979169801698116982169831698416985169861698716988169891699016991169921699316994169951699616997169981699917000170011700217003170041700517006170071700817009170101701117012170131701417015170161701717018170191702017021170221702317024170251702617027170281702917030170311703217033170341703517036170371703817039170401704117042170431704417045170461704717048170491705017051170521705317054170551705617057170581705917060170611706217063170641706517066170671706817069170701707117072170731707417075170761707717078170791708017081170821708317084170851708617087170881708917090170911709217093170941709517096170971709817099171001710117102171031710417105171061710717108171091711017111171121711317114171151711617117171181711917120171211712217123171241712517126171271712817129171301713117132171331713417135171361713717138171391714017141171421714317144171451714617147171481714917150171511715217153171541715517156171571715817159171601716117162171631716417165171661716717168171691717017171171721717317174171751717617177171781717917180171811718217183171841718517186171871718817189171901719117192171931719417195171961719717198171991720017201172021720317204172051720617207172081720917210172111721217213172141721517216172171721817219172201722117222172231722417225172261722717228172291723017231172321723317234172351723617237172381723917240172411724217243172441724517246172471724817249172501725117252172531725417255172561725717258172591726017261172621726317264172651726617267172681726917270172711727217273172741727517276172771727817279172801728117282172831728417285172861728717288172891729017291172921729317294172951729617297172981729917300173011730217303173041730517306173071730817309173101731117312173131731417315173161731717318173191732017321173221732317324173251732617327173281732917330173311733217333173341733517336173371733817339173401734117342173431734417345173461734717348173491735017351173521735317354173551735617357173581735917360173611736217363173641736517366173671736817369173701737117372173731737417375173761737717378173791738017381173821738317384173851738617387173881738917390173911739217393173941739517396173971739817399174001740117402174031740417405174061740717408174091741017411174121741317414174151741617417174181741917420174211742217423174241742517426174271742817429174301743117432174331743417435174361743717438174391744017441174421744317444174451744617447174481744917450174511745217453174541745517456174571745817459174601746117462174631746417465174661746717468174691747017471174721747317474174751747617477174781747917480174811748217483174841748517486174871748817489174901749117492174931749417495174961749717498174991750017501175021750317504175051750617507175081750917510175111751217513175141751517516175171751817519175201752117522175231752417525175261752717528175291753017531175321753317534175351753617537175381753917540175411754217543175441754517546175471754817549175501755117552175531755417555175561755717558175591756017561175621756317564175651756617567175681756917570175711757217573175741757517576175771757817579175801758117582175831758417585175861758717588175891759017591175921759317594175951759617597175981759917600176011760217603176041760517606176071760817609176101761117612176131761417615176161761717618176191762017621176221762317624176251762617627176281762917630176311763217633176341763517636176371763817639176401764117642176431764417645176461764717648176491765017651176521765317654176551765617657176581765917660176611766217663176641766517666176671766817669176701767117672176731767417675176761767717678176791768017681176821768317684176851768617687176881768917690176911769217693176941769517696176971769817699177001770117702177031770417705177061770717708177091771017711177121771317714177151771617717177181771917720177211772217723177241772517726177271772817729177301773117732177331773417735177361773717738177391774017741177421774317744177451774617747177481774917750177511775217753177541775517756177571775817759177601776117762177631776417765177661776717768177691777017771177721777317774177751777617777177781777917780177811778217783177841778517786177871778817789177901779117792177931779417795177961779717798177991780017801178021780317804178051780617807178081780917810178111781217813178141781517816178171781817819178201782117822178231782417825178261782717828178291783017831178321783317834178351783617837178381783917840178411784217843178441784517846178471784817849178501785117852178531785417855178561785717858178591786017861178621786317864178651786617867178681786917870178711787217873178741787517876178771787817879178801788117882178831788417885178861788717888178891789017891178921789317894178951789617897178981789917900179011790217903179041790517906179071790817909179101791117912179131791417915179161791717918179191792017921179221792317924179251792617927179281792917930179311793217933179341793517936179371793817939179401794117942179431794417945179461794717948179491795017951179521795317954179551795617957179581795917960179611796217963179641796517966179671796817969179701797117972179731797417975179761797717978179791798017981179821798317984179851798617987179881798917990179911799217993179941799517996179971799817999180001800118002180031800418005180061800718008180091801018011180121801318014180151801618017180181801918020180211802218023180241802518026180271802818029180301803118032180331803418035180361803718038180391804018041180421804318044180451804618047180481804918050180511805218053180541805518056180571805818059180601806118062180631806418065180661806718068180691807018071180721807318074180751807618077180781807918080180811808218083180841808518086180871808818089180901809118092180931809418095180961809718098180991810018101181021810318104181051810618107181081810918110181111811218113181141811518116181171811818119181201812118122181231812418125181261812718128181291813018131181321813318134181351813618137181381813918140181411814218143181441814518146181471814818149181501815118152181531815418155181561815718158181591816018161181621816318164181651816618167181681816918170181711817218173181741817518176181771817818179181801818118182181831818418185181861818718188181891819018191181921819318194181951819618197181981819918200182011820218203182041820518206182071820818209182101821118212182131821418215182161821718218182191822018221182221822318224182251822618227182281822918230182311823218233182341823518236182371823818239182401824118242182431824418245182461824718248182491825018251182521825318254182551825618257182581825918260182611826218263182641826518266182671826818269182701827118272182731827418275182761827718278182791828018281182821828318284182851828618287182881828918290182911829218293182941829518296182971829818299183001830118302183031830418305183061830718308183091831018311183121831318314183151831618317183181831918320183211832218323183241832518326183271832818329183301833118332183331833418335183361833718338183391834018341183421834318344183451834618347183481834918350183511835218353183541835518356183571835818359183601836118362183631836418365183661836718368183691837018371183721837318374183751837618377183781837918380183811838218383183841838518386183871838818389183901839118392183931839418395183961839718398183991840018401184021840318404184051840618407184081840918410184111841218413184141841518416184171841818419184201842118422184231842418425184261842718428184291843018431184321843318434184351843618437184381843918440184411844218443184441844518446184471844818449184501845118452184531845418455184561845718458184591846018461184621846318464184651846618467184681846918470184711847218473184741847518476184771847818479184801848118482184831848418485184861848718488184891849018491184921849318494184951849618497184981849918500185011850218503185041850518506185071850818509185101851118512185131851418515185161851718518185191852018521185221852318524185251852618527185281852918530185311853218533185341853518536185371853818539185401854118542185431854418545185461854718548185491855018551185521855318554185551855618557185581855918560185611856218563185641856518566185671856818569185701857118572185731857418575185761857718578185791858018581185821858318584185851858618587185881858918590185911859218593185941859518596185971859818599186001860118602186031860418605186061860718608186091861018611186121861318614186151861618617186181861918620186211862218623186241862518626186271862818629186301863118632186331863418635186361863718638186391864018641186421864318644186451864618647186481864918650186511865218653186541865518656186571865818659186601866118662186631866418665186661866718668186691867018671186721867318674186751867618677186781867918680186811868218683186841868518686186871868818689186901869118692186931869418695186961869718698186991870018701187021870318704187051870618707187081870918710187111871218713187141871518716187171871818719187201872118722187231872418725187261872718728187291873018731187321873318734187351873618737187381873918740187411874218743187441874518746187471874818749187501875118752187531875418755187561875718758187591876018761187621876318764187651876618767187681876918770187711877218773187741877518776187771877818779187801878118782187831878418785187861878718788187891879018791187921879318794187951879618797187981879918800188011880218803188041880518806188071880818809188101881118812188131881418815188161881718818188191882018821188221882318824188251882618827188281882918830188311883218833188341883518836188371883818839188401884118842188431884418845188461884718848188491885018851188521885318854188551885618857188581885918860188611886218863188641886518866188671886818869188701887118872188731887418875188761887718878188791888018881188821888318884188851888618887188881888918890188911889218893188941889518896188971889818899189001890118902189031890418905189061890718908189091891018911189121891318914189151891618917189181891918920189211892218923189241892518926189271892818929189301893118932189331893418935189361893718938189391894018941189421894318944189451894618947189481894918950189511895218953189541895518956189571895818959189601896118962189631896418965189661896718968189691897018971189721897318974189751897618977189781897918980189811898218983189841898518986189871898818989189901899118992189931899418995189961899718998189991900019001190021900319004190051900619007190081900919010190111901219013190141901519016190171901819019190201902119022190231902419025190261902719028190291903019031190321903319034190351903619037190381903919040190411904219043190441904519046190471904819049190501905119052190531905419055190561905719058190591906019061190621906319064190651906619067190681906919070190711907219073190741907519076190771907819079190801908119082190831908419085190861908719088190891909019091190921909319094190951909619097190981909919100191011910219103191041910519106191071910819109191101911119112191131911419115191161911719118191191912019121191221912319124191251912619127191281912919130191311913219133191341913519136191371913819139191401914119142191431914419145191461914719148191491915019151191521915319154191551915619157191581915919160191611916219163191641916519166191671916819169191701917119172191731917419175191761917719178191791918019181191821918319184191851918619187191881918919190191911919219193191941919519196191971919819199192001920119202192031920419205192061920719208192091921019211192121921319214192151921619217192181921919220192211922219223192241922519226192271922819229192301923119232192331923419235192361923719238192391924019241192421924319244192451924619247192481924919250192511925219253192541925519256192571925819259192601926119262192631926419265192661926719268192691927019271192721927319274192751927619277192781927919280192811928219283192841928519286192871928819289192901929119292192931929419295192961929719298192991930019301193021930319304193051930619307193081930919310193111931219313193141931519316193171931819319193201932119322193231932419325193261932719328193291933019331193321933319334193351933619337193381933919340193411934219343193441934519346193471934819349193501935119352193531935419355193561935719358193591936019361193621936319364193651936619367193681936919370193711937219373193741937519376193771937819379193801938119382193831938419385193861938719388193891939019391193921939319394193951939619397193981939919400194011940219403194041940519406194071940819409194101941119412194131941419415194161941719418194191942019421194221942319424194251942619427194281942919430194311943219433194341943519436194371943819439194401944119442194431944419445194461944719448194491945019451194521945319454194551945619457194581945919460194611946219463194641946519466194671946819469194701947119472194731947419475194761947719478194791948019481194821948319484194851948619487194881948919490194911949219493194941949519496194971949819499195001950119502195031950419505195061950719508195091951019511195121951319514195151951619517195181951919520195211952219523195241952519526195271952819529195301953119532195331953419535195361953719538195391954019541195421954319544195451954619547195481954919550195511955219553195541955519556195571955819559195601956119562195631956419565195661956719568195691957019571195721957319574195751957619577195781957919580195811958219583195841958519586195871958819589195901959119592195931959419595195961959719598195991960019601196021960319604196051960619607196081960919610196111961219613196141961519616196171961819619196201962119622196231962419625196261962719628196291963019631196321963319634196351963619637196381963919640196411964219643196441964519646196471964819649196501965119652196531965419655196561965719658196591966019661196621966319664196651966619667196681966919670196711967219673196741967519676196771967819679196801968119682196831968419685196861968719688196891969019691196921969319694196951969619697196981969919700197011970219703197041970519706197071970819709197101971119712197131971419715197161971719718197191972019721197221972319724197251972619727197281972919730197311973219733197341973519736197371973819739197401974119742197431974419745197461974719748197491975019751197521975319754197551975619757197581975919760197611976219763197641976519766197671976819769197701977119772197731977419775197761977719778197791978019781197821978319784197851978619787197881978919790197911979219793197941979519796197971979819799198001980119802198031980419805198061980719808198091981019811198121981319814198151981619817198181981919820198211982219823198241982519826198271982819829198301983119832198331983419835198361983719838198391984019841198421984319844198451984619847198481984919850198511985219853198541985519856198571985819859198601986119862198631986419865198661986719868198691987019871198721987319874198751987619877198781987919880198811988219883198841988519886198871988819889198901989119892198931989419895198961989719898198991990019901199021990319904199051990619907199081990919910199111991219913199141991519916199171991819919199201992119922199231992419925199261992719928199291993019931199321993319934199351993619937199381993919940199411994219943199441994519946199471994819949199501995119952199531995419955199561995719958199591996019961199621996319964199651996619967199681996919970199711997219973199741997519976199771997819979199801998119982199831998419985199861998719988199891999019991199921999319994199951999619997199981999920000200012000220003200042000520006200072000820009200102001120012200132001420015200162001720018200192002020021200222002320024200252002620027200282002920030200312003220033200342003520036200372003820039200402004120042200432004420045200462004720048200492005020051200522005320054200552005620057200582005920060200612006220063200642006520066200672006820069200702007120072200732007420075200762007720078200792008020081200822008320084200852008620087200882008920090200912009220093200942009520096200972009820099201002010120102201032010420105201062010720108201092011020111201122011320114201152011620117201182011920120201212012220123201242012520126201272012820129201302013120132201332013420135201362013720138201392014020141201422014320144201452014620147201482014920150201512015220153201542015520156201572015820159201602016120162201632016420165201662016720168201692017020171201722017320174201752017620177201782017920180201812018220183201842018520186201872018820189201902019120192201932019420195201962019720198201992020020201202022020320204202052020620207202082020920210202112021220213202142021520216202172021820219202202022120222202232022420225202262022720228202292023020231202322023320234202352023620237202382023920240202412024220243202442024520246202472024820249202502025120252202532025420255202562025720258202592026020261202622026320264202652026620267202682026920270202712027220273202742027520276202772027820279202802028120282202832028420285202862028720288202892029020291202922029320294202952029620297202982029920300203012030220303203042030520306203072030820309203102031120312203132031420315203162031720318203192032020321203222032320324203252032620327203282032920330203312033220333203342033520336203372033820339203402034120342203432034420345203462034720348203492035020351203522035320354203552035620357203582035920360203612036220363203642036520366203672036820369203702037120372203732037420375203762037720378203792038020381203822038320384203852038620387203882038920390203912039220393203942039520396203972039820399204002040120402204032040420405204062040720408204092041020411204122041320414204152041620417204182041920420204212042220423204242042520426204272042820429204302043120432204332043420435204362043720438204392044020441204422044320444204452044620447204482044920450204512045220453204542045520456204572045820459204602046120462204632046420465204662046720468204692047020471204722047320474204752047620477204782047920480204812048220483204842048520486204872048820489204902049120492204932049420495204962049720498204992050020501205022050320504205052050620507205082050920510205112051220513205142051520516205172051820519205202052120522205232052420525205262052720528205292053020531205322053320534205352053620537205382053920540205412054220543205442054520546205472054820549205502055120552205532055420555205562055720558205592056020561205622056320564205652056620567205682056920570205712057220573205742057520576205772057820579205802058120582205832058420585205862058720588205892059020591205922059320594205952059620597205982059920600206012060220603206042060520606206072060820609206102061120612206132061420615206162061720618206192062020621206222062320624206252062620627206282062920630206312063220633206342063520636206372063820639206402064120642206432064420645206462064720648206492065020651206522065320654206552065620657206582065920660206612066220663206642066520666206672066820669206702067120672206732067420675206762067720678206792068020681206822068320684206852068620687206882068920690206912069220693206942069520696206972069820699207002070120702207032070420705207062070720708207092071020711207122071320714207152071620717207182071920720207212072220723207242072520726207272072820729207302073120732207332073420735207362073720738207392074020741207422074320744207452074620747207482074920750207512075220753207542075520756207572075820759207602076120762207632076420765207662076720768207692077020771207722077320774207752077620777207782077920780207812078220783207842078520786207872078820789207902079120792207932079420795207962079720798207992080020801208022080320804208052080620807208082080920810208112081220813208142081520816208172081820819208202082120822208232082420825208262082720828208292083020831208322083320834208352083620837208382083920840208412084220843208442084520846208472084820849208502085120852208532085420855208562085720858208592086020861208622086320864208652086620867208682086920870208712087220873208742087520876208772087820879208802088120882208832088420885208862088720888208892089020891208922089320894208952089620897208982089920900209012090220903209042090520906209072090820909209102091120912209132091420915209162091720918209192092020921209222092320924209252092620927209282092920930209312093220933209342093520936209372093820939209402094120942209432094420945209462094720948209492095020951209522095320954209552095620957209582095920960209612096220963209642096520966209672096820969209702097120972209732097420975209762097720978209792098020981209822098320984209852098620987209882098920990209912099220993209942099520996209972099820999210002100121002210032100421005210062100721008210092101021011210122101321014210152101621017210182101921020210212102221023210242102521026210272102821029210302103121032210332103421035210362103721038210392104021041210422104321044210452104621047210482104921050210512105221053210542105521056210572105821059210602106121062210632106421065210662106721068210692107021071210722107321074210752107621077210782107921080210812108221083210842108521086210872108821089210902109121092210932109421095210962109721098210992110021101211022110321104211052110621107211082110921110211112111221113211142111521116211172111821119211202112121122211232112421125211262112721128211292113021131211322113321134211352113621137211382113921140211412114221143211442114521146211472114821149211502115121152211532115421155211562115721158211592116021161211622116321164211652116621167211682116921170211712117221173211742117521176211772117821179211802118121182211832118421185211862118721188211892119021191211922119321194211952119621197211982119921200212012120221203212042120521206212072120821209212102121121212212132121421215212162121721218212192122021221212222122321224212252122621227212282122921230212312123221233212342123521236212372123821239212402124121242212432124421245212462124721248212492125021251212522125321254212552125621257212582125921260212612126221263212642126521266212672126821269212702127121272212732127421275212762127721278212792128021281212822128321284212852128621287212882128921290212912129221293212942129521296212972129821299213002130121302213032130421305213062130721308213092131021311213122131321314213152131621317213182131921320213212132221323213242132521326213272132821329213302133121332213332133421335213362133721338213392134021341213422134321344213452134621347213482134921350213512135221353213542135521356213572135821359213602136121362213632136421365213662136721368213692137021371213722137321374213752137621377213782137921380213812138221383213842138521386213872138821389213902139121392213932139421395213962139721398213992140021401214022140321404214052140621407214082140921410214112141221413214142141521416214172141821419214202142121422214232142421425214262142721428214292143021431214322143321434214352143621437214382143921440214412144221443214442144521446214472144821449214502145121452214532145421455214562145721458214592146021461214622146321464214652146621467214682146921470214712147221473214742147521476214772147821479214802148121482214832148421485214862148721488214892149021491214922149321494214952149621497214982149921500215012150221503215042150521506215072150821509215102151121512215132151421515215162151721518215192152021521215222152321524215252152621527215282152921530215312153221533215342153521536215372153821539215402154121542215432154421545215462154721548215492155021551215522155321554215552155621557215582155921560215612156221563215642156521566215672156821569215702157121572215732157421575215762157721578215792158021581215822158321584215852158621587215882158921590215912159221593215942159521596215972159821599216002160121602216032160421605216062160721608216092161021611216122161321614216152161621617216182161921620216212162221623216242162521626216272162821629216302163121632216332163421635216362163721638216392164021641216422164321644216452164621647216482164921650216512165221653216542165521656216572165821659216602166121662216632166421665216662166721668216692167021671216722167321674216752167621677216782167921680216812168221683216842168521686216872168821689216902169121692216932169421695216962169721698216992170021701217022170321704217052170621707217082170921710217112171221713217142171521716217172171821719217202172121722217232172421725217262172721728217292173021731217322173321734217352173621737217382173921740217412174221743217442174521746217472174821749217502175121752217532175421755217562175721758217592176021761217622176321764217652176621767217682176921770217712177221773217742177521776217772177821779217802178121782217832178421785217862178721788217892179021791217922179321794217952179621797217982179921800218012180221803218042180521806218072180821809218102181121812218132181421815218162181721818218192182021821218222182321824218252182621827218282182921830218312183221833218342183521836218372183821839218402184121842218432184421845218462184721848218492185021851218522185321854218552185621857218582185921860218612186221863218642186521866218672186821869218702187121872218732187421875218762187721878218792188021881218822188321884218852188621887218882188921890218912189221893218942189521896218972189821899219002190121902219032190421905219062190721908219092191021911219122191321914219152191621917219182191921920219212192221923219242192521926219272192821929219302193121932219332193421935219362193721938219392194021941219422194321944219452194621947219482194921950219512195221953219542195521956219572195821959219602196121962219632196421965219662196721968219692197021971219722197321974219752197621977219782197921980219812198221983219842198521986219872198821989219902199121992219932199421995219962199721998219992200022001220022200322004220052200622007220082200922010220112201222013220142201522016220172201822019220202202122022220232202422025220262202722028220292203022031220322203322034220352203622037220382203922040220412204222043220442204522046220472204822049220502205122052220532205422055220562205722058220592206022061220622206322064220652206622067220682206922070220712207222073220742207522076220772207822079220802208122082220832208422085220862208722088220892209022091220922209322094220952209622097220982209922100221012210222103221042210522106221072210822109221102211122112221132211422115221162211722118221192212022121221222212322124221252212622127221282212922130221312213222133221342213522136221372213822139221402214122142221432214422145221462214722148221492215022151221522215322154221552215622157221582215922160221612216222163221642216522166221672216822169221702217122172221732217422175221762217722178221792218022181221822218322184221852218622187221882218922190221912219222193221942219522196221972219822199222002220122202222032220422205222062220722208222092221022211222122221322214222152221622217222182221922220222212222222223222242222522226222272222822229222302223122232222332223422235222362223722238222392224022241222422224322244222452224622247222482224922250222512225222253222542225522256222572225822259222602226122262222632226422265222662226722268222692227022271222722227322274222752227622277222782227922280222812228222283222842228522286222872228822289222902229122292222932229422295222962229722298222992230022301223022230322304223052230622307223082230922310223112231222313223142231522316223172231822319223202232122322223232232422325223262232722328223292233022331223322233322334223352233622337223382233922340223412234222343223442234522346223472234822349223502235122352223532235422355223562235722358223592236022361223622236322364223652236622367223682236922370223712237222373223742237522376223772237822379223802238122382223832238422385223862238722388223892239022391223922239322394223952239622397223982239922400224012240222403224042240522406224072240822409224102241122412224132241422415224162241722418224192242022421224222242322424224252242622427224282242922430224312243222433224342243522436224372243822439224402244122442224432244422445224462244722448224492245022451224522245322454224552245622457224582245922460224612246222463224642246522466224672246822469224702247122472224732247422475224762247722478224792248022481224822248322484224852248622487224882248922490224912249222493224942249522496224972249822499225002250122502225032250422505225062250722508225092251022511225122251322514225152251622517225182251922520225212252222523225242252522526225272252822529225302253122532225332253422535225362253722538225392254022541225422254322544225452254622547225482254922550225512255222553225542255522556225572255822559225602256122562225632256422565225662256722568225692257022571225722257322574225752257622577225782257922580225812258222583225842258522586225872258822589225902259122592225932259422595225962259722598225992260022601226022260322604226052260622607226082260922610226112261222613226142261522616226172261822619226202262122622226232262422625226262262722628226292263022631226322263322634226352263622637226382263922640226412264222643226442264522646226472264822649226502265122652226532265422655226562265722658226592266022661226622266322664226652266622667226682266922670226712267222673226742267522676226772267822679226802268122682226832268422685226862268722688226892269022691226922269322694226952269622697226982269922700227012270222703227042270522706227072270822709227102271122712227132271422715227162271722718227192272022721227222272322724227252272622727227282272922730227312273222733227342273522736227372273822739227402274122742227432274422745227462274722748227492275022751227522275322754227552275622757227582275922760227612276222763227642276522766227672276822769227702277122772227732277422775227762277722778227792278022781227822278322784227852278622787227882278922790227912279222793227942279522796227972279822799228002280122802228032280422805228062280722808228092281022811228122281322814228152281622817228182281922820228212282222823228242282522826228272282822829228302283122832228332283422835228362283722838228392284022841228422284322844228452284622847228482284922850228512285222853228542285522856228572285822859228602286122862228632286422865228662286722868228692287022871228722287322874228752287622877228782287922880228812288222883228842288522886228872288822889228902289122892228932289422895228962289722898228992290022901229022290322904229052290622907229082290922910229112291222913229142291522916229172291822919229202292122922229232292422925229262292722928229292293022931229322293322934229352293622937229382293922940229412294222943229442294522946229472294822949229502295122952229532295422955229562295722958229592296022961229622296322964229652296622967229682296922970229712297222973229742297522976229772297822979229802298122982229832298422985229862298722988229892299022991229922299322994229952299622997229982299923000230012300223003230042300523006230072300823009230102301123012230132301423015230162301723018230192302023021230222302323024230252302623027230282302923030230312303223033230342303523036230372303823039230402304123042230432304423045230462304723048230492305023051230522305323054230552305623057230582305923060230612306223063230642306523066230672306823069230702307123072230732307423075230762307723078230792308023081230822308323084230852308623087230882308923090230912309223093230942309523096230972309823099231002310123102231032310423105231062310723108231092311023111231122311323114231152311623117231182311923120231212312223123231242312523126231272312823129231302313123132231332313423135231362313723138231392314023141231422314323144231452314623147231482314923150231512315223153231542315523156231572315823159231602316123162231632316423165231662316723168231692317023171231722317323174231752317623177231782317923180231812318223183231842318523186231872318823189231902319123192231932319423195231962319723198231992320023201232022320323204232052320623207232082320923210232112321223213232142321523216232172321823219232202322123222232232322423225232262322723228232292323023231232322323323234232352323623237232382323923240232412324223243232442324523246232472324823249232502325123252232532325423255232562325723258232592326023261232622326323264232652326623267232682326923270232712327223273232742327523276232772327823279232802328123282232832328423285232862328723288232892329023291232922329323294232952329623297232982329923300233012330223303233042330523306233072330823309233102331123312233132331423315233162331723318233192332023321233222332323324233252332623327233282332923330233312333223333233342333523336233372333823339233402334123342233432334423345233462334723348233492335023351233522335323354233552335623357233582335923360233612336223363233642336523366233672336823369233702337123372233732337423375233762337723378233792338023381233822338323384233852338623387233882338923390233912339223393233942339523396233972339823399234002340123402234032340423405234062340723408234092341023411234122341323414234152341623417234182341923420234212342223423234242342523426234272342823429234302343123432234332343423435234362343723438234392344023441234422344323444234452344623447234482344923450234512345223453234542345523456234572345823459234602346123462234632346423465234662346723468234692347023471234722347323474234752347623477234782347923480234812348223483234842348523486234872348823489234902349123492234932349423495234962349723498234992350023501235022350323504235052350623507235082350923510235112351223513235142351523516235172351823519235202352123522235232352423525235262352723528235292353023531235322353323534235352353623537235382353923540235412354223543235442354523546235472354823549235502355123552235532355423555235562355723558235592356023561235622356323564235652356623567235682356923570235712357223573235742357523576235772357823579235802358123582235832358423585235862358723588235892359023591235922359323594235952359623597235982359923600236012360223603236042360523606236072360823609236102361123612236132361423615236162361723618236192362023621236222362323624236252362623627236282362923630236312363223633236342363523636236372363823639236402364123642236432364423645236462364723648236492365023651236522365323654236552365623657236582365923660236612366223663236642366523666236672366823669236702367123672236732367423675236762367723678236792368023681236822368323684236852368623687236882368923690236912369223693236942369523696236972369823699237002370123702237032370423705237062370723708237092371023711237122371323714237152371623717237182371923720237212372223723237242372523726237272372823729237302373123732237332373423735237362373723738237392374023741237422374323744237452374623747237482374923750237512375223753237542375523756237572375823759237602376123762237632376423765237662376723768237692377023771237722377323774237752377623777237782377923780237812378223783237842378523786237872378823789237902379123792237932379423795237962379723798237992380023801238022380323804238052380623807238082380923810238112381223813238142381523816238172381823819238202382123822238232382423825238262382723828238292383023831238322383323834238352383623837238382383923840238412384223843238442384523846238472384823849238502385123852238532385423855238562385723858238592386023861238622386323864238652386623867238682386923870238712387223873238742387523876238772387823879238802388123882238832388423885238862388723888238892389023891238922389323894238952389623897238982389923900239012390223903239042390523906239072390823909239102391123912239132391423915239162391723918239192392023921239222392323924239252392623927239282392923930239312393223933239342393523936239372393823939239402394123942239432394423945239462394723948239492395023951239522395323954239552395623957239582395923960239612396223963239642396523966239672396823969239702397123972239732397423975239762397723978239792398023981239822398323984239852398623987239882398923990239912399223993239942399523996239972399823999240002400124002240032400424005240062400724008240092401024011240122401324014240152401624017240182401924020240212402224023240242402524026240272402824029240302403124032240332403424035240362403724038240392404024041240422404324044240452404624047240482404924050240512405224053240542405524056240572405824059240602406124062240632406424065240662406724068240692407024071240722407324074240752407624077240782407924080240812408224083240842408524086240872408824089240902409124092240932409424095240962409724098240992410024101241022410324104241052410624107241082410924110241112411224113241142411524116241172411824119241202412124122241232412424125241262412724128241292413024131241322413324134241352413624137241382413924140241412414224143241442414524146241472414824149241502415124152241532415424155241562415724158241592416024161241622416324164241652416624167241682416924170241712417224173241742417524176241772417824179241802418124182241832418424185241862418724188241892419024191241922419324194241952419624197241982419924200242012420224203242042420524206242072420824209242102421124212242132421424215242162421724218242192422024221242222422324224242252422624227242282422924230242312423224233242342423524236242372423824239242402424124242242432424424245242462424724248242492425024251242522425324254242552425624257242582425924260242612426224263242642426524266242672426824269242702427124272242732427424275242762427724278242792428024281242822428324284242852428624287242882428924290242912429224293242942429524296242972429824299243002430124302243032430424305243062430724308243092431024311243122431324314243152431624317243182431924320243212432224323243242432524326243272432824329243302433124332243332433424335243362433724338243392434024341243422434324344243452434624347243482434924350243512435224353243542435524356243572435824359243602436124362243632436424365243662436724368243692437024371243722437324374243752437624377243782437924380243812438224383243842438524386243872438824389243902439124392243932439424395243962439724398243992440024401244022440324404244052440624407244082440924410244112441224413244142441524416244172441824419244202442124422244232442424425244262442724428244292443024431244322443324434244352443624437244382443924440244412444224443244442444524446244472444824449244502445124452244532445424455244562445724458244592446024461244622446324464244652446624467244682446924470244712447224473244742447524476244772447824479244802448124482244832448424485244862448724488244892449024491244922449324494244952449624497244982449924500245012450224503245042450524506245072450824509245102451124512245132451424515245162451724518245192452024521245222452324524245252452624527245282452924530245312453224533245342453524536245372453824539245402454124542245432454424545245462454724548245492455024551245522455324554245552455624557245582455924560245612456224563245642456524566245672456824569245702457124572245732457424575245762457724578245792458024581245822458324584245852458624587245882458924590245912459224593245942459524596245972459824599246002460124602246032460424605246062460724608246092461024611246122461324614246152461624617246182461924620246212462224623246242462524626246272462824629246302463124632246332463424635246362463724638246392464024641246422464324644246452464624647246482464924650246512465224653246542465524656246572465824659246602466124662246632466424665246662466724668246692467024671246722467324674246752467624677246782467924680246812468224683246842468524686246872468824689246902469124692246932469424695246962469724698246992470024701247022470324704247052470624707247082470924710247112471224713247142471524716247172471824719247202472124722247232472424725247262472724728247292473024731247322473324734247352473624737247382473924740247412474224743247442474524746247472474824749247502475124752247532475424755247562475724758247592476024761247622476324764247652476624767247682476924770247712477224773247742477524776247772477824779247802478124782247832478424785247862478724788247892479024791247922479324794247952479624797247982479924800248012480224803248042480524806248072480824809248102481124812248132481424815248162481724818248192482024821248222482324824248252482624827248282482924830248312483224833248342483524836248372483824839248402484124842248432484424845248462484724848248492485024851248522485324854248552485624857248582485924860248612486224863248642486524866248672486824869248702487124872248732487424875248762487724878248792488024881248822488324884248852488624887248882488924890248912489224893248942489524896248972489824899249002490124902249032490424905249062490724908249092491024911249122491324914249152491624917249182491924920249212492224923249242492524926249272492824929249302493124932249332493424935249362493724938249392494024941249422494324944249452494624947249482494924950249512495224953249542495524956249572495824959249602496124962249632496424965249662496724968249692497024971249722497324974249752497624977249782497924980249812498224983249842498524986249872498824989249902499124992249932499424995249962499724998249992500025001250022500325004250052500625007250082500925010250112501225013250142501525016250172501825019250202502125022250232502425025250262502725028250292503025031250322503325034250352503625037250382503925040250412504225043250442504525046250472504825049250502505125052250532505425055250562505725058250592506025061250622506325064250652506625067250682506925070250712507225073250742507525076250772507825079250802508125082250832508425085250862508725088250892509025091250922509325094250952509625097250982509925100251012510225103251042510525106251072510825109251102511125112251132511425115251162511725118251192512025121251222512325124251252512625127251282512925130251312513225133251342513525136251372513825139251402514125142251432514425145251462514725148251492515025151251522515325154251552515625157251582515925160251612516225163251642516525166251672516825169251702517125172251732517425175251762517725178251792518025181251822518325184251852518625187251882518925190251912519225193251942519525196251972519825199252002520125202252032520425205252062520725208252092521025211252122521325214252152521625217252182521925220252212522225223252242522525226252272522825229252302523125232252332523425235252362523725238252392524025241252422524325244252452524625247252482524925250252512525225253252542525525256252572525825259252602526125262252632526425265252662526725268252692527025271252722527325274252752527625277252782527925280252812528225283252842528525286252872528825289252902529125292252932529425295252962529725298252992530025301253022530325304253052530625307253082530925310253112531225313253142531525316253172531825319253202532125322253232532425325253262532725328253292533025331253322533325334253352533625337253382533925340253412534225343253442534525346253472534825349253502535125352253532535425355253562535725358253592536025361253622536325364253652536625367253682536925370253712537225373253742537525376253772537825379253802538125382253832538425385253862538725388253892539025391253922539325394253952539625397253982539925400254012540225403254042540525406254072540825409254102541125412254132541425415254162541725418254192542025421254222542325424254252542625427254282542925430254312543225433254342543525436254372543825439254402544125442254432544425445254462544725448254492545025451254522545325454254552545625457254582545925460254612546225463254642546525466254672546825469254702547125472254732547425475254762547725478254792548025481254822548325484254852548625487254882548925490254912549225493254942549525496254972549825499255002550125502255032550425505255062550725508255092551025511255122551325514255152551625517255182551925520255212552225523255242552525526255272552825529255302553125532255332553425535255362553725538255392554025541255422554325544255452554625547255482554925550255512555225553255542555525556255572555825559255602556125562255632556425565255662556725568255692557025571255722557325574255752557625577255782557925580255812558225583255842558525586255872558825589255902559125592255932559425595255962559725598255992560025601256022560325604256052560625607256082560925610256112561225613256142561525616256172561825619256202562125622256232562425625256262562725628256292563025631256322563325634256352563625637256382563925640256412564225643256442564525646256472564825649256502565125652256532565425655256562565725658256592566025661256622566325664256652566625667256682566925670256712567225673256742567525676256772567825679256802568125682256832568425685256862568725688256892569025691256922569325694256952569625697256982569925700257012570225703257042570525706257072570825709257102571125712257132571425715257162571725718257192572025721257222572325724257252572625727257282572925730257312573225733257342573525736257372573825739257402574125742257432574425745257462574725748257492575025751257522575325754257552575625757257582575925760257612576225763257642576525766257672576825769257702577125772257732577425775257762577725778257792578025781257822578325784257852578625787257882578925790257912579225793257942579525796257972579825799258002580125802258032580425805258062580725808258092581025811258122581325814258152581625817258182581925820258212582225823258242582525826258272582825829258302583125832258332583425835258362583725838258392584025841258422584325844258452584625847258482584925850258512585225853258542585525856258572585825859258602586125862258632586425865258662586725868258692587025871258722587325874258752587625877258782587925880258812588225883258842588525886258872588825889258902589125892258932589425895258962589725898258992590025901259022590325904259052590625907259082590925910259112591225913259142591525916259172591825919259202592125922259232592425925259262592725928259292593025931259322593325934259352593625937259382593925940259412594225943259442594525946259472594825949259502595125952259532595425955259562595725958259592596025961259622596325964259652596625967259682596925970259712597225973259742597525976259772597825979259802598125982259832598425985259862598725988259892599025991259922599325994259952599625997259982599926000260012600226003260042600526006260072600826009260102601126012260132601426015260162601726018260192602026021260222602326024260252602626027260282602926030260312603226033260342603526036260372603826039260402604126042260432604426045260462604726048260492605026051260522605326054260552605626057260582605926060260612606226063260642606526066260672606826069260702607126072260732607426075260762607726078260792608026081260822608326084260852608626087260882608926090260912609226093260942609526096260972609826099261002610126102261032610426105261062610726108261092611026111261122611326114261152611626117261182611926120261212612226123261242612526126261272612826129261302613126132261332613426135261362613726138261392614026141261422614326144261452614626147261482614926150261512615226153261542615526156261572615826159261602616126162261632616426165261662616726168261692617026171261722617326174261752617626177261782617926180261812618226183261842618526186261872618826189261902619126192261932619426195261962619726198261992620026201262022620326204262052620626207262082620926210262112621226213262142621526216262172621826219262202622126222262232622426225262262622726228262292623026231262322623326234262352623626237262382623926240262412624226243262442624526246262472624826249262502625126252262532625426255262562625726258262592626026261262622626326264262652626626267262682626926270262712627226273262742627526276262772627826279262802628126282262832628426285262862628726288262892629026291262922629326294262952629626297262982629926300263012630226303263042630526306263072630826309263102631126312263132631426315263162631726318263192632026321263222632326324263252632626327263282632926330263312633226333263342633526336263372633826339263402634126342263432634426345263462634726348263492635026351263522635326354263552635626357263582635926360263612636226363263642636526366263672636826369263702637126372263732637426375263762637726378263792638026381263822638326384263852638626387263882638926390263912639226393263942639526396263972639826399264002640126402264032640426405264062640726408264092641026411264122641326414264152641626417264182641926420264212642226423264242642526426264272642826429264302643126432264332643426435264362643726438264392644026441264422644326444264452644626447264482644926450264512645226453264542645526456264572645826459264602646126462264632646426465264662646726468264692647026471264722647326474264752647626477264782647926480264812648226483264842648526486264872648826489264902649126492264932649426495264962649726498264992650026501265022650326504265052650626507265082650926510265112651226513265142651526516265172651826519265202652126522265232652426525265262652726528265292653026531265322653326534265352653626537265382653926540265412654226543265442654526546265472654826549265502655126552265532655426555265562655726558265592656026561265622656326564265652656626567265682656926570265712657226573265742657526576265772657826579265802658126582265832658426585265862658726588265892659026591265922659326594265952659626597265982659926600266012660226603266042660526606266072660826609266102661126612266132661426615266162661726618266192662026621266222662326624266252662626627266282662926630266312663226633266342663526636266372663826639266402664126642266432664426645266462664726648266492665026651266522665326654266552665626657266582665926660266612666226663266642666526666266672666826669266702667126672266732667426675266762667726678266792668026681266822668326684266852668626687266882668926690266912669226693266942669526696266972669826699267002670126702267032670426705267062670726708267092671026711267122671326714267152671626717267182671926720267212672226723267242672526726267272672826729267302673126732267332673426735267362673726738267392674026741267422674326744267452674626747267482674926750267512675226753267542675526756267572675826759267602676126762267632676426765267662676726768267692677026771267722677326774267752677626777267782677926780267812678226783267842678526786267872678826789267902679126792267932679426795267962679726798267992680026801268022680326804268052680626807268082680926810268112681226813268142681526816268172681826819268202682126822268232682426825268262682726828268292683026831268322683326834268352683626837268382683926840268412684226843268442684526846268472684826849268502685126852268532685426855268562685726858268592686026861268622686326864268652686626867268682686926870268712687226873268742687526876268772687826879268802688126882268832688426885268862688726888268892689026891268922689326894268952689626897268982689926900269012690226903269042690526906269072690826909269102691126912269132691426915269162691726918269192692026921269222692326924269252692626927269282692926930269312693226933269342693526936269372693826939269402694126942269432694426945269462694726948269492695026951269522695326954269552695626957269582695926960269612696226963269642696526966269672696826969269702697126972269732697426975269762697726978269792698026981269822698326984269852698626987269882698926990269912699226993269942699526996269972699826999270002700127002270032700427005270062700727008270092701027011270122701327014270152701627017270182701927020270212702227023270242702527026270272702827029270302703127032270332703427035270362703727038270392704027041270422704327044270452704627047270482704927050270512705227053270542705527056270572705827059270602706127062270632706427065270662706727068270692707027071270722707327074270752707627077270782707927080270812708227083270842708527086270872708827089270902709127092270932709427095270962709727098270992710027101271022710327104271052710627107271082710927110271112711227113271142711527116271172711827119271202712127122271232712427125271262712727128271292713027131271322713327134271352713627137271382713927140271412714227143271442714527146271472714827149271502715127152271532715427155271562715727158271592716027161271622716327164271652716627167271682716927170271712717227173271742717527176271772717827179271802718127182271832718427185271862718727188271892719027191271922719327194271952719627197271982719927200272012720227203272042720527206272072720827209272102721127212272132721427215272162721727218272192722027221272222722327224272252722627227272282722927230272312723227233272342723527236272372723827239272402724127242272432724427245272462724727248272492725027251272522725327254272552725627257272582725927260272612726227263272642726527266272672726827269272702727127272272732727427275272762727727278272792728027281272822728327284272852728627287272882728927290272912729227293272942729527296272972729827299273002730127302273032730427305273062730727308273092731027311273122731327314273152731627317273182731927320273212732227323273242732527326273272732827329273302733127332273332733427335273362733727338273392734027341273422734327344273452734627347273482734927350273512735227353273542735527356273572735827359273602736127362273632736427365273662736727368273692737027371273722737327374273752737627377273782737927380273812738227383273842738527386273872738827389273902739127392273932739427395273962739727398273992740027401274022740327404274052740627407274082740927410274112741227413274142741527416274172741827419274202742127422274232742427425274262742727428274292743027431274322743327434274352743627437274382743927440274412744227443274442744527446274472744827449274502745127452274532745427455274562745727458274592746027461274622746327464274652746627467274682746927470274712747227473274742747527476274772747827479274802748127482274832748427485274862748727488274892749027491274922749327494274952749627497274982749927500275012750227503275042750527506275072750827509275102751127512275132751427515275162751727518275192752027521275222752327524275252752627527275282752927530275312753227533275342753527536275372753827539275402754127542275432754427545275462754727548275492755027551275522755327554275552755627557275582755927560275612756227563275642756527566275672756827569275702757127572275732757427575275762757727578275792758027581275822758327584275852758627587275882758927590275912759227593275942759527596275972759827599276002760127602276032760427605276062760727608276092761027611276122761327614276152761627617276182761927620276212762227623276242762527626276272762827629276302763127632276332763427635276362763727638276392764027641276422764327644276452764627647276482764927650276512765227653276542765527656276572765827659276602766127662276632766427665276662766727668276692767027671276722767327674276752767627677276782767927680276812768227683276842768527686276872768827689276902769127692276932769427695276962769727698276992770027701277022770327704277052770627707277082770927710277112771227713277142771527716277172771827719277202772127722277232772427725277262772727728277292773027731277322773327734277352773627737277382773927740277412774227743277442774527746277472774827749277502775127752277532775427755277562775727758277592776027761277622776327764277652776627767277682776927770277712777227773277742777527776277772777827779277802778127782277832778427785277862778727788277892779027791277922779327794277952779627797277982779927800278012780227803278042780527806278072780827809278102781127812278132781427815278162781727818278192782027821278222782327824278252782627827278282782927830278312783227833278342783527836278372783827839278402784127842278432784427845278462784727848278492785027851278522785327854278552785627857278582785927860278612786227863278642786527866278672786827869278702787127872278732787427875278762787727878278792788027881278822788327884278852788627887278882788927890278912789227893278942789527896278972789827899279002790127902279032790427905279062790727908279092791027911279122791327914279152791627917279182791927920279212792227923279242792527926279272792827929279302793127932279332793427935279362793727938279392794027941279422794327944279452794627947279482794927950279512795227953279542795527956279572795827959279602796127962279632796427965279662796727968279692797027971279722797327974279752797627977279782797927980279812798227983279842798527986279872798827989279902799127992279932799427995279962799727998279992800028001280022800328004280052800628007280082800928010280112801228013280142801528016280172801828019280202802128022280232802428025280262802728028280292803028031280322803328034280352803628037280382803928040280412804228043280442804528046280472804828049280502805128052280532805428055280562805728058280592806028061280622806328064280652806628067280682806928070280712807228073280742807528076280772807828079280802808128082280832808428085280862808728088280892809028091280922809328094280952809628097280982809928100281012810228103281042810528106281072810828109281102811128112281132811428115281162811728118281192812028121281222812328124281252812628127281282812928130281312813228133281342813528136281372813828139281402814128142281432814428145281462814728148281492815028151281522815328154281552815628157281582815928160281612816228163281642816528166281672816828169281702817128172281732817428175281762817728178281792818028181281822818328184281852818628187281882818928190281912819228193281942819528196281972819828199282002820128202282032820428205282062820728208282092821028211282122821328214282152821628217282182821928220282212822228223282242822528226282272822828229282302823128232282332823428235282362823728238282392824028241282422824328244282452824628247282482824928250282512825228253282542825528256282572825828259282602826128262282632826428265282662826728268282692827028271282722827328274282752827628277282782827928280282812828228283282842828528286282872828828289282902829128292282932829428295282962829728298282992830028301283022830328304283052830628307283082830928310283112831228313283142831528316283172831828319283202832128322283232832428325283262832728328283292833028331283322833328334283352833628337283382833928340283412834228343283442834528346283472834828349283502835128352283532835428355283562835728358283592836028361283622836328364283652836628367283682836928370283712837228373283742837528376283772837828379283802838128382283832838428385283862838728388283892839028391283922839328394283952839628397283982839928400284012840228403284042840528406284072840828409284102841128412284132841428415284162841728418284192842028421284222842328424284252842628427284282842928430284312843228433284342843528436284372843828439284402844128442284432844428445284462844728448284492845028451284522845328454284552845628457284582845928460284612846228463284642846528466284672846828469284702847128472284732847428475284762847728478284792848028481284822848328484284852848628487284882848928490284912849228493284942849528496284972849828499285002850128502285032850428505285062850728508285092851028511285122851328514285152851628517285182851928520285212852228523285242852528526285272852828529285302853128532285332853428535285362853728538285392854028541285422854328544285452854628547285482854928550285512855228553285542855528556285572855828559285602856128562285632856428565285662856728568285692857028571285722857328574285752857628577285782857928580285812858228583285842858528586285872858828589285902859128592285932859428595285962859728598285992860028601286022860328604286052860628607286082860928610286112861228613286142861528616286172861828619286202862128622286232862428625286262862728628286292863028631286322863328634286352863628637286382863928640286412864228643286442864528646286472864828649286502865128652286532865428655286562865728658286592866028661286622866328664286652866628667286682866928670286712867228673286742867528676286772867828679286802868128682286832868428685286862868728688286892869028691286922869328694286952869628697286982869928700287012870228703287042870528706287072870828709287102871128712287132871428715287162871728718287192872028721287222872328724287252872628727287282872928730287312873228733287342873528736287372873828739287402874128742287432874428745287462874728748287492875028751287522875328754287552875628757287582875928760287612876228763287642876528766287672876828769287702877128772287732877428775287762877728778287792878028781287822878328784287852878628787287882878928790287912879228793287942879528796287972879828799288002880128802288032880428805288062880728808288092881028811288122881328814288152881628817288182881928820288212882228823288242882528826288272882828829288302883128832288332883428835288362883728838288392884028841288422884328844288452884628847288482884928850288512885228853288542885528856288572885828859288602886128862288632886428865288662886728868288692887028871288722887328874288752887628877288782887928880288812888228883288842888528886288872888828889288902889128892288932889428895288962889728898288992890028901289022890328904289052890628907289082890928910289112891228913289142891528916289172891828919289202892128922289232892428925289262892728928289292893028931289322893328934289352893628937289382893928940289412894228943289442894528946289472894828949289502895128952289532895428955289562895728958289592896028961289622896328964289652896628967289682896928970289712897228973289742897528976289772897828979289802898128982289832898428985289862898728988289892899028991289922899328994289952899628997289982899929000290012900229003290042900529006290072900829009290102901129012290132901429015290162901729018290192902029021290222902329024290252902629027290282902929030290312903229033290342903529036290372903829039290402904129042290432904429045290462904729048290492905029051290522905329054290552905629057290582905929060290612906229063290642906529066290672906829069290702907129072290732907429075290762907729078290792908029081290822908329084290852908629087290882908929090290912909229093290942909529096290972909829099291002910129102291032910429105291062910729108291092911029111291122911329114291152911629117291182911929120291212912229123291242912529126291272912829129291302913129132291332913429135291362913729138291392914029141291422914329144291452914629147291482914929150291512915229153291542915529156291572915829159291602916129162291632916429165291662916729168291692917029171291722917329174291752917629177291782917929180291812918229183291842918529186291872918829189291902919129192291932919429195291962919729198291992920029201292022920329204292052920629207292082920929210292112921229213292142921529216292172921829219292202922129222292232922429225292262922729228292292923029231292322923329234292352923629237292382923929240292412924229243292442924529246292472924829249292502925129252292532925429255292562925729258292592926029261292622926329264292652926629267292682926929270292712927229273292742927529276292772927829279292802928129282292832928429285292862928729288292892929029291292922929329294292952929629297292982929929300293012930229303293042930529306293072930829309293102931129312293132931429315293162931729318293192932029321293222932329324293252932629327293282932929330293312933229333293342933529336293372933829339293402934129342293432934429345293462934729348293492935029351293522935329354293552935629357293582935929360293612936229363293642936529366293672936829369293702937129372293732937429375293762937729378293792938029381293822938329384293852938629387293882938929390293912939229393293942939529396293972939829399294002940129402294032940429405294062940729408294092941029411294122941329414294152941629417294182941929420294212942229423294242942529426294272942829429294302943129432294332943429435294362943729438294392944029441294422944329444294452944629447294482944929450294512945229453294542945529456294572945829459294602946129462294632946429465294662946729468294692947029471294722947329474294752947629477294782947929480294812948229483294842948529486294872948829489294902949129492294932949429495294962949729498294992950029501295022950329504295052950629507295082950929510295112951229513295142951529516295172951829519295202952129522295232952429525295262952729528295292953029531295322953329534295352953629537295382953929540295412954229543295442954529546295472954829549295502955129552295532955429555295562955729558295592956029561295622956329564295652956629567295682956929570295712957229573295742957529576295772957829579295802958129582295832958429585295862958729588295892959029591295922959329594295952959629597295982959929600296012960229603296042960529606296072960829609296102961129612296132961429615296162961729618296192962029621296222962329624296252962629627296282962929630296312963229633296342963529636296372963829639296402964129642296432964429645296462964729648296492965029651296522965329654296552965629657296582965929660296612966229663296642966529666296672966829669296702967129672296732967429675296762967729678296792968029681296822968329684296852968629687296882968929690296912969229693296942969529696296972969829699297002970129702297032970429705297062970729708297092971029711297122971329714297152971629717297182971929720297212972229723297242972529726297272972829729297302973129732297332973429735297362973729738297392974029741297422974329744297452974629747297482974929750297512975229753297542975529756297572975829759297602976129762297632976429765297662976729768297692977029771297722977329774297752977629777297782977929780297812978229783297842978529786297872978829789297902979129792297932979429795297962979729798297992980029801298022980329804298052980629807298082980929810298112981229813298142981529816298172981829819298202982129822298232982429825298262982729828298292983029831298322983329834298352983629837298382983929840298412984229843298442984529846298472984829849298502985129852298532985429855298562985729858298592986029861298622986329864298652986629867298682986929870298712987229873298742987529876298772987829879298802988129882298832988429885298862988729888298892989029891298922989329894298952989629897298982989929900299012990229903299042990529906299072990829909299102991129912299132991429915299162991729918299192992029921299222992329924299252992629927299282992929930299312993229933299342993529936299372993829939299402994129942299432994429945299462994729948299492995029951299522995329954299552995629957299582995929960299612996229963299642996529966299672996829969299702997129972299732997429975299762997729978299792998029981299822998329984299852998629987299882998929990299912999229993299942999529996299972999829999300003000130002300033000430005300063000730008300093001030011300123001330014300153001630017300183001930020300213002230023300243002530026300273002830029300303003130032300333003430035300363003730038300393004030041300423004330044300453004630047300483004930050300513005230053300543005530056300573005830059300603006130062300633006430065300663006730068300693007030071300723007330074300753007630077300783007930080300813008230083300843008530086300873008830089300903009130092300933009430095300963009730098300993010030101301023010330104301053010630107301083010930110301113011230113301143011530116301173011830119301203012130122301233012430125301263012730128301293013030131301323013330134301353013630137301383013930140301413014230143301443014530146301473014830149301503015130152301533015430155301563015730158301593016030161301623016330164301653016630167301683016930170301713017230173301743017530176301773017830179301803018130182301833018430185301863018730188301893019030191301923019330194301953019630197301983019930200302013020230203302043020530206302073020830209302103021130212302133021430215302163021730218302193022030221302223022330224302253022630227302283022930230302313023230233302343023530236302373023830239302403024130242302433024430245302463024730248302493025030251302523025330254302553025630257302583025930260302613026230263302643026530266302673026830269302703027130272302733027430275302763027730278302793028030281302823028330284302853028630287302883028930290302913029230293302943029530296302973029830299303003030130302303033030430305303063030730308303093031030311303123031330314303153031630317303183031930320303213032230323303243032530326303273032830329303303033130332303333033430335303363033730338303393034030341303423034330344303453034630347303483034930350303513035230353303543035530356303573035830359303603036130362303633036430365303663036730368303693037030371303723037330374303753037630377303783037930380303813038230383303843038530386303873038830389303903039130392303933039430395303963039730398303993040030401304023040330404304053040630407304083040930410304113041230413304143041530416304173041830419304203042130422304233042430425304263042730428304293043030431304323043330434304353043630437304383043930440304413044230443304443044530446304473044830449304503045130452304533045430455304563045730458304593046030461304623046330464304653046630467304683046930470304713047230473304743047530476304773047830479304803048130482304833048430485304863048730488304893049030491304923049330494304953049630497304983049930500305013050230503305043050530506305073050830509305103051130512305133051430515305163051730518305193052030521305223052330524305253052630527305283052930530305313053230533305343053530536305373053830539305403054130542305433054430545305463054730548305493055030551305523055330554305553055630557305583055930560305613056230563305643056530566305673056830569305703057130572305733057430575305763057730578305793058030581305823058330584305853058630587305883058930590305913059230593305943059530596305973059830599306003060130602306033060430605306063060730608306093061030611306123061330614306153061630617306183061930620306213062230623306243062530626306273062830629306303063130632306333063430635306363063730638306393064030641306423064330644306453064630647306483064930650306513065230653306543065530656306573065830659306603066130662306633066430665306663066730668306693067030671306723067330674306753067630677306783067930680306813068230683306843068530686306873068830689306903069130692306933069430695306963069730698306993070030701307023070330704307053070630707307083070930710307113071230713307143071530716307173071830719307203072130722307233072430725307263072730728307293073030731307323073330734307353073630737307383073930740307413074230743307443074530746307473074830749307503075130752307533075430755307563075730758307593076030761307623076330764307653076630767307683076930770307713077230773307743077530776307773077830779307803078130782307833078430785307863078730788307893079030791307923079330794307953079630797307983079930800308013080230803308043080530806308073080830809308103081130812308133081430815308163081730818308193082030821308223082330824308253082630827308283082930830308313083230833308343083530836308373083830839308403084130842308433084430845308463084730848308493085030851308523085330854308553085630857308583085930860308613086230863308643086530866308673086830869308703087130872308733087430875308763087730878308793088030881308823088330884308853088630887308883088930890308913089230893308943089530896308973089830899309003090130902309033090430905309063090730908309093091030911309123091330914309153091630917309183091930920309213092230923309243092530926309273092830929309303093130932309333093430935309363093730938309393094030941309423094330944309453094630947309483094930950309513095230953309543095530956309573095830959309603096130962309633096430965309663096730968309693097030971309723097330974309753097630977309783097930980309813098230983309843098530986309873098830989309903099130992309933099430995309963099730998309993100031001310023100331004310053100631007310083100931010310113101231013310143101531016310173101831019310203102131022310233102431025310263102731028310293103031031310323103331034310353103631037310383103931040310413104231043310443104531046310473104831049310503105131052310533105431055310563105731058310593106031061310623106331064310653106631067310683106931070310713107231073310743107531076310773107831079310803108131082310833108431085310863108731088310893109031091310923109331094310953109631097310983109931100311013110231103311043110531106311073110831109311103111131112311133111431115311163111731118311193112031121311223112331124311253112631127311283112931130311313113231133311343113531136311373113831139311403114131142311433114431145311463114731148311493115031151311523115331154311553115631157311583115931160311613116231163311643116531166311673116831169311703117131172311733117431175311763117731178311793118031181311823118331184311853118631187311883118931190311913119231193311943119531196311973119831199312003120131202312033120431205312063120731208312093121031211312123121331214312153121631217312183121931220312213122231223312243122531226312273122831229312303123131232312333123431235312363123731238312393124031241312423124331244312453124631247312483124931250312513125231253312543125531256312573125831259312603126131262312633126431265312663126731268312693127031271312723127331274312753127631277312783127931280312813128231283312843128531286312873128831289312903129131292312933129431295312963129731298312993130031301313023130331304313053130631307313083130931310313113131231313313143131531316313173131831319313203132131322313233132431325313263132731328313293133031331313323133331334313353133631337313383133931340313413134231343313443134531346313473134831349313503135131352313533135431355313563135731358313593136031361313623136331364313653136631367313683136931370313713137231373313743137531376313773137831379313803138131382313833138431385313863138731388313893139031391313923139331394313953139631397313983139931400314013140231403314043140531406314073140831409314103141131412314133141431415314163141731418314193142031421314223142331424314253142631427314283142931430314313143231433314343143531436314373143831439314403144131442314433144431445314463144731448314493145031451314523145331454314553145631457314583145931460314613146231463314643146531466314673146831469314703147131472314733147431475314763147731478314793148031481314823148331484314853148631487314883148931490314913149231493314943149531496314973149831499315003150131502315033150431505315063150731508315093151031511315123151331514315153151631517315183151931520315213152231523315243152531526315273152831529315303153131532315333153431535315363153731538315393154031541315423154331544315453154631547315483154931550315513155231553315543155531556315573155831559315603156131562315633156431565315663156731568315693157031571315723157331574315753157631577315783157931580315813158231583315843158531586315873158831589315903159131592315933159431595315963159731598315993160031601316023160331604316053160631607316083160931610316113161231613316143161531616316173161831619316203162131622316233162431625316263162731628316293163031631316323163331634316353163631637316383163931640316413164231643316443164531646316473164831649316503165131652316533165431655316563165731658316593166031661316623166331664316653166631667316683166931670316713167231673316743167531676316773167831679316803168131682316833168431685316863168731688316893169031691316923169331694316953169631697316983169931700317013170231703317043170531706317073170831709317103171131712317133171431715317163171731718317193172031721317223172331724317253172631727317283172931730317313173231733317343173531736317373173831739317403174131742317433174431745317463174731748317493175031751317523175331754317553175631757317583175931760317613176231763317643176531766317673176831769317703177131772317733177431775317763177731778317793178031781317823178331784317853178631787317883178931790317913179231793317943179531796317973179831799318003180131802318033180431805318063180731808318093181031811318123181331814318153181631817318183181931820318213182231823318243182531826318273182831829318303183131832318333183431835318363183731838318393184031841318423184331844318453184631847318483184931850318513185231853318543185531856318573185831859318603186131862318633186431865318663186731868318693187031871318723187331874318753187631877318783187931880318813188231883318843188531886318873188831889318903189131892318933189431895318963189731898318993190031901319023190331904319053190631907319083190931910319113191231913319143191531916319173191831919319203192131922319233192431925319263192731928319293193031931319323193331934319353193631937319383193931940319413194231943319443194531946319473194831949319503195131952319533195431955319563195731958319593196031961319623196331964319653196631967319683196931970319713197231973319743197531976319773197831979319803198131982319833198431985319863198731988319893199031991319923199331994319953199631997319983199932000320013200232003320043200532006320073200832009320103201132012320133201432015320163201732018320193202032021320223202332024320253202632027320283202932030320313203232033320343203532036320373203832039320403204132042320433204432045320463204732048320493205032051320523205332054320553205632057320583205932060320613206232063320643206532066320673206832069320703207132072320733207432075320763207732078320793208032081320823208332084320853208632087320883208932090320913209232093320943209532096320973209832099321003210132102321033210432105321063210732108321093211032111321123211332114321153211632117321183211932120321213212232123321243212532126321273212832129321303213132132321333213432135321363213732138321393214032141321423214332144321453214632147321483214932150321513215232153321543215532156321573215832159321603216132162321633216432165321663216732168321693217032171321723217332174321753217632177321783217932180321813218232183321843218532186321873218832189321903219132192321933219432195321963219732198321993220032201322023220332204322053220632207322083220932210322113221232213322143221532216322173221832219322203222132222322233222432225322263222732228322293223032231322323223332234322353223632237322383223932240322413224232243322443224532246322473224832249322503225132252322533225432255322563225732258322593226032261322623226332264322653226632267322683226932270322713227232273322743227532276322773227832279322803228132282322833228432285322863228732288322893229032291322923229332294322953229632297322983229932300323013230232303323043230532306323073230832309323103231132312323133231432315323163231732318323193232032321323223232332324323253232632327323283232932330323313233232333323343233532336323373233832339323403234132342323433234432345323463234732348323493235032351323523235332354323553235632357323583235932360323613236232363323643236532366323673236832369323703237132372323733237432375323763237732378323793238032381323823238332384323853238632387323883238932390323913239232393323943239532396323973239832399324003240132402324033240432405324063240732408324093241032411324123241332414324153241632417324183241932420324213242232423324243242532426324273242832429324303243132432324333243432435324363243732438324393244032441324423244332444324453244632447324483244932450324513245232453324543245532456324573245832459324603246132462324633246432465324663246732468324693247032471324723247332474324753247632477324783247932480324813248232483324843248532486324873248832489324903249132492324933249432495324963249732498324993250032501325023250332504325053250632507325083250932510325113251232513325143251532516325173251832519325203252132522325233252432525325263252732528325293253032531325323253332534325353253632537325383253932540325413254232543325443254532546325473254832549325503255132552325533255432555325563255732558325593256032561325623256332564325653256632567325683256932570325713257232573325743257532576325773257832579325803258132582325833258432585325863258732588325893259032591325923259332594325953259632597325983259932600326013260232603326043260532606326073260832609326103261132612326133261432615326163261732618326193262032621326223262332624326253262632627326283262932630326313263232633326343263532636326373263832639326403264132642326433264432645326463264732648326493265032651326523265332654326553265632657326583265932660326613266232663326643266532666326673266832669326703267132672326733267432675326763267732678326793268032681326823268332684326853268632687326883268932690326913269232693326943269532696326973269832699327003270132702327033270432705327063270732708327093271032711327123271332714327153271632717327183271932720327213272232723327243272532726327273272832729327303273132732327333273432735327363273732738327393274032741327423274332744327453274632747327483274932750327513275232753327543275532756327573275832759327603276132762327633276432765327663276732768327693277032771327723277332774327753277632777327783277932780327813278232783327843278532786327873278832789327903279132792327933279432795327963279732798327993280032801328023280332804328053280632807328083280932810328113281232813328143281532816328173281832819328203282132822328233282432825328263282732828328293283032831328323283332834328353283632837328383283932840328413284232843328443284532846328473284832849328503285132852328533285432855328563285732858328593286032861328623286332864328653286632867328683286932870328713287232873328743287532876328773287832879328803288132882328833288432885328863288732888328893289032891328923289332894328953289632897328983289932900329013290232903329043290532906329073290832909329103291132912329133291432915329163291732918329193292032921329223292332924329253292632927329283292932930329313293232933329343293532936329373293832939329403294132942329433294432945329463294732948329493295032951329523295332954329553295632957329583295932960329613296232963329643296532966329673296832969329703297132972329733297432975329763297732978329793298032981329823298332984329853298632987329883298932990329913299232993329943299532996329973299832999330003300133002330033300433005330063300733008330093301033011330123301333014330153301633017330183301933020330213302233023330243302533026330273302833029330303303133032330333303433035330363303733038330393304033041330423304333044330453304633047330483304933050330513305233053330543305533056330573305833059330603306133062330633306433065330663306733068330693307033071330723307333074330753307633077330783307933080330813308233083330843308533086330873308833089330903309133092330933309433095330963309733098330993310033101331023310333104331053310633107331083310933110331113311233113331143311533116331173311833119331203312133122331233312433125331263312733128331293313033131331323313333134331353313633137331383313933140331413314233143331443314533146331473314833149331503315133152331533315433155331563315733158331593316033161331623316333164331653316633167331683316933170331713317233173331743317533176331773317833179331803318133182331833318433185331863318733188331893319033191331923319333194331953319633197331983319933200332013320233203332043320533206332073320833209332103321133212332133321433215332163321733218332193322033221332223322333224332253322633227332283322933230332313323233233332343323533236332373323833239332403324133242332433324433245332463324733248332493325033251332523325333254332553325633257332583325933260332613326233263332643326533266332673326833269332703327133272332733327433275332763327733278332793328033281332823328333284332853328633287332883328933290332913329233293332943329533296332973329833299333003330133302333033330433305333063330733308333093331033311333123331333314333153331633317333183331933320333213332233323333243332533326333273332833329333303333133332333333333433335333363333733338333393334033341333423334333344333453334633347333483334933350333513335233353333543335533356333573335833359333603336133362333633336433365333663336733368333693337033371333723337333374333753337633377333783337933380333813338233383333843338533386333873338833389333903339133392333933339433395333963339733398333993340033401334023340333404334053340633407334083340933410334113341233413334143341533416334173341833419334203342133422334233342433425334263342733428334293343033431334323343333434334353343633437334383343933440334413344233443334443344533446334473344833449334503345133452334533345433455334563345733458334593346033461334623346333464334653346633467334683346933470334713347233473334743347533476334773347833479334803348133482334833348433485334863348733488334893349033491334923349333494334953349633497334983349933500335013350233503335043350533506335073350833509335103351133512335133351433515335163351733518335193352033521335223352333524335253352633527335283352933530335313353233533335343353533536335373353833539335403354133542335433354433545335463354733548335493355033551335523355333554335553355633557335583355933560335613356233563335643356533566335673356833569335703357133572335733357433575335763357733578335793358033581335823358333584335853358633587335883358933590335913359233593335943359533596335973359833599336003360133602336033360433605336063360733608336093361033611336123361333614336153361633617336183361933620336213362233623336243362533626336273362833629336303363133632336333363433635336363363733638336393364033641336423364333644336453364633647336483364933650336513365233653336543365533656336573365833659336603366133662336633366433665336663366733668336693367033671336723367333674336753367633677336783367933680336813368233683336843368533686336873368833689336903369133692336933369433695336963369733698336993370033701337023370333704337053370633707337083370933710337113371233713337143371533716337173371833719337203372133722337233372433725337263372733728337293373033731337323373333734337353373633737337383373933740337413374233743337443374533746337473374833749337503375133752337533375433755337563375733758337593376033761337623376333764337653376633767337683376933770337713377233773337743377533776337773377833779337803378133782337833378433785337863378733788337893379033791337923379333794337953379633797337983379933800338013380233803338043380533806338073380833809338103381133812338133381433815338163381733818338193382033821338223382333824338253382633827338283382933830338313383233833338343383533836338373383833839338403384133842338433384433845338463384733848338493385033851338523385333854338553385633857338583385933860338613386233863338643386533866338673386833869338703387133872338733387433875338763387733878338793388033881338823388333884338853388633887338883388933890338913389233893338943389533896338973389833899339003390133902339033390433905339063390733908339093391033911339123391333914339153391633917339183391933920339213392233923339243392533926339273392833929339303393133932339333393433935339363393733938339393394033941339423394333944339453394633947339483394933950339513395233953339543395533956339573395833959339603396133962339633396433965339663396733968339693397033971339723397333974339753397633977339783397933980339813398233983339843398533986339873398833989339903399133992339933399433995339963399733998339993400034001340023400334004340053400634007340083400934010340113401234013340143401534016340173401834019340203402134022340233402434025340263402734028340293403034031340323403334034340353403634037340383403934040340413404234043340443404534046340473404834049340503405134052340533405434055340563405734058340593406034061340623406334064340653406634067340683406934070340713407234073340743407534076340773407834079340803408134082340833408434085340863408734088340893409034091340923409334094340953409634097340983409934100341013410234103341043410534106341073410834109341103411134112341133411434115341163411734118341193412034121341223412334124341253412634127341283412934130341313413234133341343413534136341373413834139341403414134142341433414434145341463414734148341493415034151341523415334154341553415634157341583415934160341613416234163341643416534166341673416834169341703417134172341733417434175341763417734178341793418034181341823418334184341853418634187341883418934190341913419234193341943419534196341973419834199342003420134202342033420434205342063420734208342093421034211342123421334214342153421634217342183421934220342213422234223342243422534226342273422834229342303423134232342333423434235342363423734238342393424034241342423424334244342453424634247342483424934250342513425234253342543425534256342573425834259342603426134262342633426434265342663426734268342693427034271342723427334274342753427634277342783427934280342813428234283342843428534286342873428834289342903429134292342933429434295342963429734298342993430034301343023430334304343053430634307343083430934310343113431234313343143431534316343173431834319343203432134322343233432434325343263432734328343293433034331343323433334334343353433634337343383433934340343413434234343343443434534346343473434834349343503435134352343533435434355343563435734358343593436034361343623436334364343653436634367343683436934370343713437234373343743437534376343773437834379343803438134382343833438434385343863438734388343893439034391343923439334394343953439634397343983439934400344013440234403344043440534406344073440834409344103441134412344133441434415344163441734418344193442034421344223442334424344253442634427344283442934430344313443234433344343443534436344373443834439344403444134442344433444434445344463444734448344493445034451344523445334454344553445634457344583445934460344613446234463344643446534466344673446834469344703447134472344733447434475344763447734478344793448034481344823448334484344853448634487344883448934490344913449234493344943449534496344973449834499345003450134502345033450434505345063450734508345093451034511345123451334514345153451634517345183451934520345213452234523345243452534526345273452834529345303453134532345333453434535345363453734538345393454034541345423454334544345453454634547345483454934550345513455234553345543455534556345573455834559345603456134562345633456434565345663456734568345693457034571345723457334574345753457634577345783457934580345813458234583345843458534586345873458834589345903459134592345933459434595345963459734598345993460034601346023460334604346053460634607346083460934610346113461234613346143461534616346173461834619346203462134622346233462434625346263462734628346293463034631346323463334634346353463634637346383463934640346413464234643346443464534646346473464834649346503465134652346533465434655346563465734658346593466034661346623466334664346653466634667346683466934670346713467234673346743467534676346773467834679346803468134682346833468434685346863468734688346893469034691346923469334694346953469634697346983469934700347013470234703347043470534706347073470834709347103471134712347133471434715347163471734718347193472034721347223472334724347253472634727347283472934730347313473234733347343473534736347373473834739347403474134742347433474434745347463474734748347493475034751347523475334754347553475634757347583475934760347613476234763347643476534766347673476834769347703477134772347733477434775347763477734778347793478034781347823478334784347853478634787347883478934790347913479234793347943479534796347973479834799348003480134802348033480434805348063480734808348093481034811348123481334814348153481634817348183481934820348213482234823348243482534826348273482834829348303483134832348333483434835348363483734838348393484034841348423484334844348453484634847348483484934850348513485234853348543485534856348573485834859348603486134862348633486434865348663486734868348693487034871348723487334874348753487634877348783487934880348813488234883348843488534886348873488834889348903489134892348933489434895348963489734898348993490034901349023490334904349053490634907349083490934910349113491234913349143491534916349173491834919349203492134922349233492434925349263492734928349293493034931349323493334934349353493634937349383493934940349413494234943349443494534946349473494834949349503495134952349533495434955349563495734958349593496034961349623496334964349653496634967349683496934970349713497234973349743497534976349773497834979349803498134982349833498434985349863498734988349893499034991349923499334994349953499634997349983499935000350013500235003350043500535006350073500835009350103501135012350133501435015350163501735018350193502035021350223502335024350253502635027350283502935030350313503235033350343503535036350373503835039350403504135042350433504435045350463504735048350493505035051350523505335054350553505635057350583505935060350613506235063350643506535066350673506835069350703507135072350733507435075350763507735078350793508035081350823508335084350853508635087350883508935090350913509235093350943509535096350973509835099351003510135102351033510435105351063510735108351093511035111351123511335114351153511635117351183511935120351213512235123351243512535126351273512835129351303513135132351333513435135351363513735138351393514035141351423514335144351453514635147351483514935150351513515235153351543515535156351573515835159351603516135162351633516435165351663516735168351693517035171351723517335174351753517635177351783517935180351813518235183351843518535186351873518835189351903519135192351933519435195351963519735198351993520035201352023520335204352053520635207352083520935210352113521235213352143521535216352173521835219352203522135222352233522435225352263522735228352293523035231352323523335234352353523635237352383523935240352413524235243352443524535246352473524835249352503525135252352533525435255352563525735258352593526035261352623526335264352653526635267352683526935270352713527235273352743527535276352773527835279352803528135282352833528435285352863528735288352893529035291352923529335294352953529635297352983529935300353013530235303353043530535306353073530835309353103531135312353133531435315353163531735318353193532035321353223532335324353253532635327353283532935330353313533235333353343533535336353373533835339353403534135342353433534435345353463534735348353493535035351353523535335354353553535635357353583535935360353613536235363353643536535366353673536835369353703537135372353733537435375353763537735378353793538035381353823538335384353853538635387353883538935390353913539235393353943539535396353973539835399354003540135402354033540435405354063540735408354093541035411354123541335414354153541635417354183541935420354213542235423354243542535426354273542835429354303543135432354333543435435354363543735438354393544035441354423544335444354453544635447354483544935450354513545235453354543545535456354573545835459354603546135462354633546435465354663546735468354693547035471354723547335474354753547635477354783547935480354813548235483354843548535486354873548835489354903549135492354933549435495354963549735498354993550035501355023550335504355053550635507355083550935510355113551235513355143551535516355173551835519355203552135522355233552435525355263552735528355293553035531355323553335534355353553635537355383553935540355413554235543355443554535546355473554835549355503555135552355533555435555355563555735558355593556035561355623556335564355653556635567355683556935570355713557235573355743557535576355773557835579355803558135582355833558435585355863558735588355893559035591355923559335594355953559635597355983559935600356013560235603356043560535606356073560835609356103561135612356133561435615356163561735618356193562035621356223562335624356253562635627356283562935630356313563235633356343563535636356373563835639356403564135642356433564435645356463564735648356493565035651356523565335654356553565635657356583565935660356613566235663356643566535666356673566835669356703567135672356733567435675356763567735678356793568035681356823568335684356853568635687356883568935690356913569235693356943569535696356973569835699357003570135702357033570435705357063570735708357093571035711357123571335714357153571635717357183571935720357213572235723357243572535726357273572835729357303573135732357333573435735357363573735738357393574035741357423574335744357453574635747357483574935750357513575235753357543575535756357573575835759357603576135762357633576435765357663576735768357693577035771357723577335774357753577635777357783577935780357813578235783357843578535786357873578835789357903579135792357933579435795357963579735798357993580035801358023580335804358053580635807358083580935810358113581235813358143581535816358173581835819358203582135822358233582435825358263582735828358293583035831358323583335834358353583635837358383583935840358413584235843358443584535846358473584835849358503585135852358533585435855358563585735858358593586035861358623586335864358653586635867358683586935870358713587235873358743587535876358773587835879358803588135882358833588435885358863588735888358893589035891358923589335894358953589635897358983589935900359013590235903359043590535906359073590835909359103591135912359133591435915359163591735918359193592035921359223592335924359253592635927359283592935930359313593235933359343593535936359373593835939359403594135942359433594435945359463594735948359493595035951359523595335954359553595635957359583595935960359613596235963359643596535966359673596835969359703597135972359733597435975359763597735978359793598035981359823598335984359853598635987359883598935990359913599235993359943599535996359973599835999360003600136002360033600436005360063600736008360093601036011360123601336014360153601636017360183601936020360213602236023360243602536026360273602836029360303603136032360333603436035360363603736038360393604036041360423604336044360453604636047360483604936050360513605236053360543605536056360573605836059360603606136062360633606436065360663606736068360693607036071360723607336074360753607636077360783607936080360813608236083360843608536086360873608836089360903609136092360933609436095360963609736098360993610036101361023610336104361053610636107361083610936110361113611236113361143611536116361173611836119361203612136122361233612436125361263612736128361293613036131361323613336134361353613636137361383613936140361413614236143361443614536146361473614836149361503615136152361533615436155361563615736158361593616036161361623616336164361653616636167361683616936170361713617236173361743617536176361773617836179361803618136182361833618436185361863618736188361893619036191361923619336194361953619636197361983619936200362013620236203362043620536206362073620836209362103621136212362133621436215362163621736218362193622036221362223622336224362253622636227362283622936230362313623236233362343623536236362373623836239362403624136242362433624436245362463624736248362493625036251362523625336254362553625636257362583625936260362613626236263362643626536266362673626836269362703627136272362733627436275362763627736278362793628036281362823628336284362853628636287362883628936290362913629236293362943629536296362973629836299363003630136302363033630436305363063630736308363093631036311363123631336314363153631636317363183631936320363213632236323363243632536326363273632836329363303633136332363333633436335363363633736338 |
- {
- 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 = [];
- JSONNewLine = {$IFDEF Windows}'\r\n'{$ELSE}'\n'{$ENDIF};
- type
- TSrcMarkerKind = (
- mkLabel,
- mkResolverReference,
- mkDirectReference
- );
- const
- SrcMarker: array[TSrcMarkerKind] of char = (
- '#', // mkLabel
- '@', // mkResolverReference
- '=' // mkDirectReference
- );
- type
- 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;
- TTestResolverReferenceData = record
- Filename: string;
- Row: integer;
- StartCol: integer;
- EndCol: integer;
- Found: TFPList; // list of TPasElement at this token
- end;
- PTestResolverReferenceData = ^TTestResolverReferenceData;
- { 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;
- procedure SetModule(const AValue: TPasModule);
- public
- destructor Destroy; override;
- function CreateElement(AClass: TPTreeElement; const AName: String;
- AParent: TPasElement; AVisibility: TPasMemberVisibility;
- const ASrcPos: TPasSourcePos; TypeParams: TFPList = nil): TPasElement;
- overload; 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 write SetModule;
- end;
- { TCustomTestModule }
- TCustomTestModule = Class(TTestCase)
- private
- FWithTypeInfo: boolean;
- FSource: TStringList;
- FSkipTests: boolean;
- FScanner: TPas2jsPasScanner;
- FResolvers: TObjectList;// list of TTestEnginePasResolver
- FPasProgram: TPasProgram;
- FPasLibrary: TPasLibrary;
- FParser: TTestPasParser;
- FModule: TPasModule;
- FJSSource: TStringList;
- FJSRegModuleCall: TJSCallExpression;
- FJSModuleSrc: TJSSourceElements;
- FJSModuleCallArgs: TJSArguments;
- FJSModule: TJSSourceElements;
- FJSInterfaceUses: TJSArrayLiteral;
- FJSInitBody: TJSFunctionBody;
- FJSImplentationUses: TJSArrayLiteral;
- FJSImplementationUses: TJSArrayLiteral;
- FHub: TPas2JSResolverHub;
- FHintMsgsGood: TFPList; // list of TTestHintMessage marked as expected
- FHintMsgs: TObjectList; // list of TTestHintMessage
- FFirstPasStatement: TPasImplBlock;
- FFileResolver: TStreamResolver;
- FFilename: string;
- FExpectedErrorNumber: integer;
- FExpectedErrorMsg: string;
- FExpectedErrorClass: ExceptClass;
- FEngine: TTestEnginePasResolver;
- FConverter: TPasToJSConverter;
- {$IFDEF EnablePasTreeGlobalRefCount}
- FElementRefCountAtSetup: int64;
- {$ENDIF}
- procedure FreeSrcMarkers;
- function GetResolverCount: integer;
- function GetResolvers(Index: integer): TTestEnginePasResolver;
- function GetMsgCount: integer;
- function GetMsgs(Index: integer): TTestHintMessage;
- 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 OnCheckElementParent(El: TPasElement; arg: pointer);
- procedure OnFindReference(El: TPasElement; FindData: pointer);
- 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 ParseLibrary; virtual;
- procedure ParseUnit; virtual;
- protected
- FirstSrcMarker, LastSrcMarker: PSrcMarker;
- 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 StartLibrary(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
- procedure StartUnit(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
- procedure ConvertModule; virtual;
- procedure ConvertProgram; virtual;
- procedure ConvertLibrary; 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 CheckFullSource(Msg,ExpectedSrc: String); virtual;
- procedure CheckDiff(Msg, Expected, Actual: string); virtual;
- procedure CheckUnit(aFilename, ExpectedSrc: string); virtual;
- procedure CheckReferenceDirectives; 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 RaiseErrorAtSrc(Msg: string; const aFilename: string; aRow, aCol: integer);
- procedure RaiseErrorAtSrcMarker(Msg: string; aMarker: PSrcMarker);
- 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 aFilename: string): integer;
- function GetResolver(const aFilename: string): TTestEnginePasResolver;
- procedure GetSrc(Index: integer; out SrcLines: TStringList; out aFilename: string);
- function FindElementsAt(aFilename: string; aLine, aStartCol, aEndCol: integer): TFPList;// list of TPasElement
- function FindElementsAt(aMarker: PSrcMarker; ErrorOnNoElements: boolean = true): TFPList;// list of TPasElement
- function FindSrcLabel(const Identifier: string): PSrcMarker;
- function FindElementsAtSrcLabel(const Identifier: string; ErrorOnNoElements: boolean = true): TFPList;// list of TPasElement
- function GetDefaultNamespace: string;
- property PasProgram: TPasProgram Read FPasProgram;
- property PasLibrary: TPasLibrary Read FPasLibrary;
- property ResolverEngine: 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 Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
- property ResolverCount: integer read GetResolverCount;
- 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 TestDoubleSmall;
- Procedure TestInteger;
- Procedure TestIntegerRange;
- Procedure TestIntegerTypecasts;
- Procedure TestInteger_BitwiseShrNativeInt;
- Procedure TestInteger_BitwiseShlNativeInt;
- Procedure TestInteger_SystemFunc;
- Procedure TestInteger_AssignOutsideConst;
- 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 TestStringConstWhitespaces;
- Procedure TestStringConst_Multiline;
- 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_ResultAbsolute;
- 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;
- Procedure TestArray_ConstRef;
- Procedure TestArray_Concat;
- Procedure TestArray_Concat_Append;
- Procedure TestArray_Concat_Append_Var;
- Procedure TestArray_Copy;
- Procedure TestArray_InsertDelete;
- Procedure TestArray_Add_Append;
- 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_ArrayConstMultiline;
- // anonymous record
- Procedure TestRecordAnonym_Field;
- Procedure TestRecordAnonym_Assign;
- Procedure TestRecordAnonym_Nested;
- Procedure TestRecordAnonym_Const;
- Procedure TestRecordAnonym_InFunction;
- // 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;
- Procedure TestClass_Property;
- Procedure TestClass_Property_ClassMethod;
- Procedure TestClass_Property_ClassMethodStatic;
- 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;
- Procedure TestNestedClass_CallInherited;
- // 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;
- Procedure TestExternalClass_NestedConstructor;
- // class interfaces
- Procedure TestClassInterface_Corba;
- Procedure TestClassInterface_Corba_ProcExternalFail;
- Procedure TestClassInterface_Corba_Overloads;
- Procedure TestClassInterface_Corba_DuplicateGUIInIntfListFail;
- Procedure TestClassInterface_Corba_DuplicateGUIInAncestorFail;
- Procedure TestClassInterface_Corba_AncestorImpl;
- Procedure TestClassInterface_Corba_ImplReintroduce;
- Procedure TestClassInterface_Corba_MethodResolution;
- Procedure TestClassInterface_COM_AncestorMoreInterfaces;
- Procedure TestClassInterface_Corba_MethodOverride;
- Procedure TestClassInterface_Corba_Delegation;
- Procedure TestClassInterface_Corba_DelegationStatic;
- Procedure TestClassInterface_Corba_Operators;
- Procedure TestClassInterface_Corba_Args;
- Procedure TestClassInterface_Corba_ForIn;
- Procedure TestClassInterface_Corba_ArrayOfIntf;
- Procedure TestClassInterface_COM_AssignVar;
- Procedure TestClassInterface_COM_AssignArg;
- Procedure TestClassInterface_COM_FunctionResult;
- Procedure TestClassInterface_COM_InheritedFuncResult;
- Procedure TestClassInterface_COM_FunctionExit;
- 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_ForObjectInInterface;
- Procedure TestClassInterface_COM_ForInterfaceInObject;
- Procedure TestClassInterface_COM_ArrayOfIntf; // todo
- Procedure TestClassInterface_COM_ArrayOfIntfFail;
- Procedure TestClassInterface_COM_RecordIntfFail;
- Procedure TestClassInterface_COM_UnitInitialization;
- Procedure TestClassInterface_Corba_GUID;
- Procedure TestClassInterface_Corba_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;
- Procedure TestProcType_SafeCall_Arg;
- // 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_ProcTypeAnonymous;
- 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_FieldPrivate;
- Procedure TestRTTI_Class_Method;
- Procedure TestRTTI_Class_MethodArgFlags;
- Procedure TestRTTI_Class_MethodPrivate;
- Procedure TestRTTI_Class_Property;
- Procedure TestRTTI_Class_PropertyParams;
- Procedure TestRTTI_Class_PropertyPrivate;
- Procedure TestRTTI_Class_ClassProperty;
- 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;
- Procedure TestAttributes_InterfacesList;
- // 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;
- procedure TestRangeChecks_AssignCurrency;
- // 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_AnonymousProc_PromiseViaDotContext;
- Procedure TestAsync_ProcType;
- Procedure TestAsync_ProcTypeAsyncModMismatchFail;
- Procedure TestAsync_Inherited;
- Procedure TestAsync_ClassInterface;
- Procedure TestAsync_ClassInterface_AsyncMissmatchFail;
- Procedure TestAWait_ClassAs;
- // Library
- Procedure TestLibrary_Empty;
- Procedure TestLibrary_ExportFunc;
- Procedure TestLibrary_ExportFuncOverloadedFail;
- Procedure TestLibrary_Export_Index_Fail;
- Procedure TestLibrary_ExportVar;
- Procedure TestLibrary_ExportUnitFunc;
- 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 }
- procedure TTestEnginePasResolver.SetModule(const AValue: TPasModule);
- begin
- if FModule=AValue then Exit;
- FModule:=AValue;
- end;
- destructor TTestEnginePasResolver.Destroy;
- begin
- FreeAndNil(FStreamResolver);
- FreeAndNil(FParser);
- FreeAndNil(FScanner);
- FreeAndNil(FStreamResolver);
- Module:=nil;
- inherited Destroy;
- end;
- function TTestEnginePasResolver.CreateElement(AClass: TPTreeElement;
- const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility;
- const ASrcPos: TPasSourcePos; TypeParams: TFPList): TPasElement;
- begin
- Result:=inherited CreateElement(AClass, AName, AParent, AVisibility, ASrcPos,
- TypeParams);
- if (FModule=nil) and AClass.InheritsFrom(TPasModule) then
- Module:=TPasModule(Result);
- 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 }
- procedure TCustomTestModule.FreeSrcMarkers;
- var
- aMarker, Last: PSrcMarker;
- begin
- aMarker:=FirstSrcMarker;
- while aMarker<>nil do
- begin
- Last:=aMarker;
- aMarker:=aMarker^.Next;
- Dispose(Last);
- end;
- FirstSrcMarker:=nil;
- LastSrcMarker:=nil;
- end;
- function TCustomTestModule.GetResolverCount: integer;
- begin
- Result:=FResolvers.Count;
- end;
- function TCustomTestModule.GetResolvers(Index: integer): TTestEnginePasResolver;
- begin
- Result:=TTestEnginePasResolver(FResolvers[Index]);
- end;
- function TCustomTestModule.GetMsgCount: integer;
- begin
- Result:=FHintMsgs.Count;
- end;
- function TCustomTestModule.GetMsgs(Index: integer): TTestHintMessage;
- begin
- Result:=TTestHintMessage(FHintMsgs[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.OnCheckElementParent(El: TPasElement; arg: pointer);
- var
- SubEl: TPasElement;
- i: Integer;
- procedure E(Msg: string);
- var
- s: String;
- begin
- s:='TCustomTestModule.OnCheckElementParent El='+GetTreeDbg(El)+' '+
- ResolverEngine.GetElementSourcePosStr(El)+' '+Msg;
- writeln('ERROR: ',s);
- Fail(s);
- end;
- begin
- if arg=nil then ;
- if El=nil then exit;
- if El.Parent=El then
- E('El.Parent=El='+GetObjName(El));
- if El is TBinaryExpr then
- begin
- if (TBinaryExpr(El).left<>nil) and (TBinaryExpr(El).left.Parent<>El) then
- E('TBinaryExpr(El).left.Parent='+GetObjName(TBinaryExpr(El).left.Parent)+'<>El');
- if (TBinaryExpr(El).right<>nil) and (TBinaryExpr(El).right.Parent<>El) then
- E('TBinaryExpr(El).right.Parent='+GetObjName(TBinaryExpr(El).right.Parent)+'<>El');
- end
- else if El is TParamsExpr then
- begin
- if (TParamsExpr(El).Value<>nil) and (TParamsExpr(El).Value.Parent<>El) then
- E('TParamsExpr(El).Value.Parent='+GetObjName(TParamsExpr(El).Value.Parent)+'<>El');
- for i:=0 to length(TParamsExpr(El).Params)-1 do
- if TParamsExpr(El).Params[i].Parent<>El then
- E('TParamsExpr(El).Params[i].Parent='+GetObjName(TParamsExpr(El).Params[i].Parent)+'<>El');
- end
- else if El is TProcedureExpr then
- begin
- if (TProcedureExpr(El).Proc<>nil) and (TProcedureExpr(El).Proc.Parent<>El) then
- E('TProcedureExpr(El).Proc.Parent='+GetObjName(TProcedureExpr(El).Proc.Parent)+'<>El');
- end
- else if El is TPasDeclarations then
- begin
- for i:=0 to TPasDeclarations(El).Declarations.Count-1 do
- begin
- SubEl:=TPasElement(TPasDeclarations(El).Declarations[i]);
- if SubEl.Parent<>El then
- E('SubEl=TPasElement(TPasDeclarations(El).Declarations[i])='+GetObjName(SubEl)+' SubEl.Parent='+GetObjName(SubEl.Parent)+'<>El');
- end;
- end
- else if El is TPasImplBlock then
- begin
- for i:=0 to TPasImplBlock(El).Elements.Count-1 do
- begin
- SubEl:=TPasElement(TPasImplBlock(El).Elements[i]);
- if SubEl.Parent<>El then
- E('TPasElement(TPasImplBlock(El).Elements[i]).Parent='+GetObjName(SubEl.Parent)+'<>El');
- end;
- end
- else if El is TPasImplWithDo then
- begin
- for i:=0 to TPasImplWithDo(El).Expressions.Count-1 do
- begin
- SubEl:=TPasExpr(TPasImplWithDo(El).Expressions[i]);
- if SubEl.Parent<>El then
- E('TPasExpr(TPasImplWithDo(El).Expressions[i]).Parent='+GetObjName(SubEl.Parent)+'<>El');
- end;
- end
- else if El is TPasProcedure then
- begin
- if TPasProcedure(El).ProcType.Parent<>El then
- E('TPasProcedure(El).ProcType.Parent='+GetObjName(TPasProcedure(El).ProcType.Parent)+'<>El');
- end
- else if El is TPasProcedureType then
- begin
- for i:=0 to TPasProcedureType(El).Args.Count-1 do
- if TPasArgument(TPasProcedureType(El).Args[i]).Parent<>El then
- E('TPasArgument(TPasProcedureType(El).Args[i]).Parent='+GetObjName(TPasArgument(TPasProcedureType(El).Args[i]).Parent)+'<>El');
- end;
- end;
- procedure TCustomTestModule.OnFindReference(El: TPasElement; FindData: pointer);
- var
- Data: PTestResolverReferenceData absolute FindData;
- Line, Col: integer;
- begin
- ResolverEngine.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col);
- //writeln('TCustomTestModule.OnFindReference ',El.SourceFilename,' Line=',Line,',Col=',Col,' ',GetObjName(El),' SearchFile=',Data^.Filename,',Line=',Data^.Row,',Col=',Data^.StartCol,'-',Data^.EndCol);
- if (Data^.Filename=El.SourceFilename)
- and (Data^.Row=Line)
- and (Data^.StartCol<=Col)
- and (Data^.EndCol>=Col)
- then
- Data^.Found.Add(El);
- 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 FResolvers<>nil then
- begin
- writeln('TCustomTestModule.SetUp FModules<>nil');
- Halt;
- end;
- inherited SetUp;
- FSkipTests:=false;
- FWithTypeInfo:=false;
- FSource:=TStringList.Create;
- FHub:=TPas2JSResolverHub.Create(Self);
- FResolvers:=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
- FreeSrcMarkers;
- 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);
- ResolverEngine.Clear;
- FreeAndNil(FSource);
- FreeAndNil(FFileResolver);
- if FResolvers<>nil then
- begin
- for i:=0 to FResolvers.Count-1 do
- begin
- CurModule:=TTestEnginePasResolver(FResolvers[i]).Module;
- if CurModule=nil then continue;
- //writeln('TCustomTestModule.TearDown ReleaseUsedUnits ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
- end;
- for i:=0 to FResolvers.Count-1 do
- begin
- CurModule:=TTestEnginePasResolver(FResolvers[i]).Module;
- if CurModule=nil then continue;
- //writeln('TCustomTestModule.TearDown UsesReleased ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
- end;
- FreeAndNil(FResolvers);
- FModule:=nil;
- 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 Resolvers 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',ResolverEngine,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.ParseLibrary;
- var
- Init: TInitializationSection;
- begin
- if SkipTests then exit;
- ParseModule;
- if SkipTests then exit;
- AssertEquals('Has library',TPasLibrary,Module.ClassType);
- FPasLibrary:=TPasLibrary(Module);
- AssertNotNull('Has library section',PasLibrary.LibrarySection);
- Init:=PasLibrary.InitializationSection;
- if (Init<>nil) and (Init.Elements.Count>0) then
- if TObject(Init.Elements[0]) is TPasImplBlock then
- FFirstPasStatement:=TPasImplBlock(PasLibrary.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;
- FResolvers.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.StartLibrary(NeedSystemUnit: boolean;
- SystemUnitParts: TSystemUnitParts);
- begin
- if NeedSystemUnit then
- AddSystemUnit(SystemUnitParts)
- else
- Parser.ImplicitUses.Clear;
- Add('library '+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, FirstNode: TJSElement;
- Arg: TJSArrayLiteralElement;
- IsProg, IsLib: Boolean;
- begin
- if SkipTests then exit;
- IsProg:=false;
- IsLib:=false;
- if Module is TPasProgram then
- IsProg:=true
- else if Module is TPasLibrary then
- IsLib:=true;
- try
- FJSModule:=FConverter.ConvertPasElement(Module,ResolverEngine) 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(...
- if JSModule.Statements.Count<1 then
- AssertEquals('jsmodule has at least one statement - the call',1,JSModule.Statements.Count);
- FirstNode:=JSModule.Statements.Nodes[0].Node;
- AssertNotNull('register module call',FirstNode);
- AssertEquals('register module call',TJSCallExpression,FirstNode.ClassType);
- FJSRegModuleCall:=FirstNode 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 IsProg then
- begin
- AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString));
- AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
- end
- else if IsLib then
- AssertEquals('module name','library',String(ModuleNameExpr.Value.AsString))
- else
- begin
- AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
- AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
- end;
- // 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 IsProg or IsLib then
- begin
- InitName:='$main';
- AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
- end
- else
- InitName:='$init';
- InitAssign:=nil;
- InitFunction:=nil;
- 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 IsProg or IsLib 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.ConvertLibrary;
- begin
- Add('end.');
- ParseLibrary;
- 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;
- IsProg, IsLib: Boolean;
- 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
- IsProg:=false;
- IsLib:=false;
- if Module is TPasProgram then
- IsProg:=true
- else if Module is TPasLibrary then
- IsLib:=true;
- if IsProg or IsLib or (Trim(InitStatements)<>'') then
- begin
- if IsProg or IsLib 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),'"');
- //writeln('TCustomTestModule.CheckSource ',ActualSrc);
- CheckDiff(Msg,ExpectedSrc,ActualSrc);
- end;
- procedure TCustomTestModule.CheckFullSource(Msg, ExpectedSrc: String);
- var
- ActualSrc: String;
- begin
- ActualSrc:=JSToStr(JSModule);
- 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(aFilename, ExpectedSrc: string);
- var
- aResolver: TTestEnginePasResolver;
- aConverter: TPasToJSConverter;
- aJSModule: TJSSourceElements;
- ActualSrc: String;
- begin
- aResolver:=GetResolver(aFilename);
- AssertNotNull('missing resolver of unit '+aFilename,aResolver);
- AssertNotNull('missing resolver.module of unit '+aFilename,aResolver.Module);
- {$IFDEF VerbosePas2JS}
- writeln('CheckUnit '+aFilename+' 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.CheckReferenceDirectives;
- var
- CurFilename: string;
- LineNumber: Integer;
- SrcLine: String;
- CommentStartP, CommentEndP: PChar;
- procedure RaiseError(Msg: string; p: PChar);
- begin
- RaiseErrorAtSrc(Msg,CurFilename,LineNumber,p-PChar(SrcLine)+1);
- end;
- procedure AddMarker(Marker: PSrcMarker);
- begin
- if LastSrcMarker<>nil then
- LastSrcMarker^.Next:=Marker
- else
- FirstSrcMarker:=Marker;
- LastSrcMarker:=Marker;
- end;
- function AddMarker(Kind: TSrcMarkerKind; const aFilename: string;
- aLine, aStartCol, aEndCol: integer; const Identifier: string): PSrcMarker;
- begin
- New(Result);
- Result^.Kind:=Kind;
- Result^.Filename:=aFilename;
- Result^.Row:=aLine;
- Result^.StartCol:=aStartCol;
- Result^.EndCol:=aEndCol;
- Result^.Identifier:=Identifier;
- Result^.Next:=nil;
- //writeln('AddMarker Line="',SrcLine,'" Identifier=',Identifier,' Col=',aStartCol,'-',aEndCol,' "',copy(SrcLine,aStartCol,aEndCol-aStartCol),'"');
- AddMarker(Result);
- end;
- function AddMarkerForTokenBehindComment(Kind: TSrcMarkerKind;
- const Identifier: string): PSrcMarker;
- var
- TokenStart, p: PChar;
- begin
- p:=CommentEndP;
- ReadNextPascalToken(p,TokenStart,false,false);
- Result:=AddMarker(Kind,CurFilename,LineNumber,
- CommentEndP-PChar(SrcLine)+1,p-PChar(SrcLine)+1,Identifier);
- end;
- function ReadIdentifier(var p: PChar): string;
- var
- StartP: PChar;
- begin
- if not (p^ in ['a'..'z','A'..'Z','_']) then
- RaiseError('identifier expected',p);
- StartP:=p;
- inc(p);
- while p^ in ['a'..'z','A'..'Z','_','0'..'9'] do inc(p);
- Result:='';
- SetLength(Result,p-StartP);
- Move(StartP^,Result[1],length(Result));
- end;
- procedure AddLabel;
- var
- Identifier: String;
- p: PChar;
- begin
- p:=CommentStartP+2;
- Identifier:=ReadIdentifier(p);
- //writeln('TCustomTestModule.CheckReferenceDirectives.AddLabel ',Identifier);
- if FindSrcLabel(Identifier)<>nil then
- RaiseError('duplicate label "'+Identifier+'"',p);
- AddMarkerForTokenBehindComment(mkLabel,Identifier);
- end;
- procedure AddResolverReference;
- var
- Identifier: String;
- p: PChar;
- begin
- p:=CommentStartP+2;
- Identifier:=ReadIdentifier(p);
- //writeln('TCustomTestModule.CheckReferenceDirectives.AddReference ',Identifier);
- AddMarkerForTokenBehindComment(mkResolverReference,Identifier);
- end;
- procedure AddDirectReference;
- var
- Identifier: String;
- p: PChar;
- begin
- p:=CommentStartP+2;
- Identifier:=ReadIdentifier(p);
- //writeln('TCustomTestModule.CheckReferenceDirectives.AddDirectReference ',Identifier);
- AddMarkerForTokenBehindComment(mkDirectReference,Identifier);
- end;
- procedure ParseCode(SrcLines: TStringList; aFilename: string);
- var
- p: PChar;
- IsDirective: Boolean;
- begin
- //writeln('TCustomTestModule.CheckReferenceDirectives.ParseCode File=',aFilename);
- CurFilename:=aFilename;
- // parse code, find all labels
- LineNumber:=0;
- while LineNumber<SrcLines.Count do
- begin
- inc(LineNumber);
- SrcLine:=SrcLines[LineNumber-1];
- if SrcLine='' then continue;
- //writeln('TCustomTestModule.CheckReferenceDirectives Line=',SrcLine);
- p:=PChar(SrcLine);
- repeat
- case p^ of
- #0: if (p-PChar(SrcLine)=length(SrcLine)) then break;
- '{':
- begin
- CommentStartP:=p;
- inc(p);
- IsDirective:=p^ in ['#','@','='];
- // skip to end of comment
- repeat
- case p^ of
- #0:
- if (p-PChar(SrcLine)=length(SrcLine)) then
- begin
- // multi line comment
- if IsDirective then
- RaiseError('directive missing closing bracket',CommentStartP);
- repeat
- inc(LineNumber);
- if LineNumber>SrcLines.Count then exit;
- SrcLine:=SrcLines[LineNumber-1];
- //writeln('TCustomTestModule.CheckReferenceDirectives Comment Line=',SrcLine);
- until SrcLine<>'';
- p:=PChar(SrcLine);
- continue;
- end;
- '}':
- begin
- inc(p);
- break;
- end;
- end;
- inc(p);
- until false;
- CommentEndP:=p;
- case CommentStartP[1] of
- '#': AddLabel;
- '@': AddResolverReference;
- '=': AddDirectReference;
- end;
- p:=CommentEndP;
- continue;
- end;
- '/':
- if p[1]='/' then
- break; // rest of line is comment -> skip
- end;
- inc(p);
- until false;
- end;
- end;
- procedure CheckResolverReference(aMarker: PSrcMarker);
- // check if one element at {@a} has a TResolvedReference to an element labeled {#a}
- var
- aLabel: PSrcMarker;
- ReferenceElements, LabelElements: TFPList;
- i, j, aLine, aCol: Integer;
- El, Ref, LabelEl: TPasElement;
- begin
- //writeln('TCustomTestModule.CheckResolverReference searching reference: ',aMarker^.Filename,' Line=',aMarker^.Row,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"');
- aLabel:=FindSrcLabel(aMarker^.Identifier);
- if aLabel=nil then
- RaiseErrorAtSrc('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.Row,aMarker^.StartCol);
- LabelElements:=nil;
- ReferenceElements:=nil;
- try
- LabelElements:=FindElementsAt(aLabel);
- ReferenceElements:=FindElementsAt(aMarker);
- for i:=0 to ReferenceElements.Count-1 do
- begin
- El:=TPasElement(ReferenceElements[i]);
- Ref:=nil;
- if El.CustomData is TResolvedReference then
- Ref:=TResolvedReference(El.CustomData).Declaration
- else if El.CustomData is TPasPropertyScope then
- Ref:=TPasPropertyScope(El.CustomData).AncestorProp
- else if El.CustomData is TPasSpecializeTypeData then
- Ref:=TPasSpecializeTypeData(El.CustomData).SpecializedType;
- if Ref<>nil then
- for j:=0 to LabelElements.Count-1 do
- begin
- LabelEl:=TPasElement(LabelElements[j]);
- if Ref=LabelEl then
- exit; // success
- end;
- end;
- // failure write candidates
- for i:=0 to ReferenceElements.Count-1 do
- begin
- El:=TPasElement(ReferenceElements[i]);
- write('Reference candidate for "',aMarker^.Identifier,'" at reference ',aMarker^.Filename,'(',aMarker^.Row,',',aMarker^.StartCol,'-',aMarker^.EndCol,')');
- write(' El=',GetObjName(El));
- if EL is TPrimitiveExpr then
- begin
- writeln('TCustomTestModule.CheckResolverReference ',TPrimitiveExpr(El).Value);
- end;
- Ref:=nil;
- if El.CustomData is TResolvedReference then
- Ref:=TResolvedReference(El.CustomData).Declaration
- else if El.CustomData is TPasPropertyScope then
- Ref:=TPasPropertyScope(El.CustomData).AncestorProp
- else if El.CustomData is TPasSpecializeTypeData then
- Ref:=TPasSpecializeTypeData(El.CustomData).SpecializedType;
- if Ref<>nil then
- begin
- write(' Decl=',GetObjName(Ref));
- ResolverEngine.UnmangleSourceLineNumber(Ref.SourceLinenumber,aLine,aCol);
- write(',',Ref.SourceFilename,'(',aLine,',',aCol,')');
- end
- else
- write(' has no TResolvedReference. El.CustomData=',GetObjName(El.CustomData));
- writeln;
- end;
- for i:=0 to LabelElements.Count-1 do
- begin
- El:=TPasElement(LabelElements[i]);
- write('Label candidate for "',aLabel^.Identifier,'" at reference ',aLabel^.Filename,'(',aLabel^.Row,',',aLabel^.StartCol,'-',aLabel^.EndCol,')');
- write(' El=',GetObjName(El));
- writeln;
- end;
- RaiseErrorAtSrcMarker('wrong resolved reference "'+aMarker^.Identifier+'"',aMarker);
- finally
- LabelElements.Free;
- ReferenceElements.Free;
- end;
- end;
- procedure CheckDirectReference(aMarker: PSrcMarker);
- // check if one element at {=a} is a TPasAliasType pointing to an element labeled {#a}
- var
- aLabel: PSrcMarker;
- ReferenceElements, LabelElements: TFPList;
- i, LabelLine, LabelCol, j: Integer;
- El, LabelEl: TPasElement;
- DeclEl, TypeEl: TPasType;
- begin
- //writeln('CheckDirectReference searching pointer: ',aMarker^.Filename,' Line=',aMarker^.Row,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"');
- aLabel:=FindSrcLabel(aMarker^.Identifier);
- if aLabel=nil then
- RaiseErrorAtSrcMarker('label "'+aMarker^.Identifier+'" not found',aMarker);
- LabelElements:=nil;
- ReferenceElements:=nil;
- try
- //writeln('CheckDirectReference finding elements at label ...');
- LabelElements:=FindElementsAt(aLabel);
- //writeln('CheckDirectReference finding elements at reference ...');
- ReferenceElements:=FindElementsAt(aMarker);
- for i:=0 to ReferenceElements.Count-1 do
- begin
- El:=TPasElement(ReferenceElements[i]);
- //writeln('CheckDirectReference ',i,'/',ReferenceElements.Count,' ',GetTreeDbg(El,2));
- if El.ClassType=TPasVariable then
- begin
- if TPasVariable(El).VarType=nil then
- begin
- //writeln('CheckDirectReference Var without Type: ',GetObjName(El),' El.Parent=',GetObjName(El.Parent));
- AssertNotNull('TPasVariable(El='+El.Name+').VarType',TPasVariable(El).VarType);
- end;
- TypeEl:=TPasVariable(El).VarType;
- for j:=0 to LabelElements.Count-1 do
- begin
- LabelEl:=TPasElement(LabelElements[j]);
- if TypeEl=LabelEl then
- exit; // success
- end;
- end
- else if El is TPasAliasType then
- begin
- DeclEl:=TPasAliasType(El).DestType;
- ResolverEngine.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol);
- if (aLabel^.Filename=DeclEl.SourceFilename)
- and (integer(aLabel^.Row)=LabelLine)
- and (aLabel^.StartCol<=LabelCol)
- and (aLabel^.EndCol>=LabelCol) then
- exit; // success
- end
- else if El.ClassType=TPasArgument then
- begin
- TypeEl:=TPasArgument(El).ArgType;
- for j:=0 to LabelElements.Count-1 do
- begin
- LabelEl:=TPasElement(LabelElements[j]);
- if TypeEl=LabelEl then
- exit; // success
- end;
- end;
- end;
- // failed -> show candidates
- writeln('CheckDirectReference failed: Labels:');
- for j:=0 to LabelElements.Count-1 do
- begin
- LabelEl:=TPasElement(LabelElements[j]);
- writeln(' Label ',GetObjName(LabelEl),' at ',ResolverEngine.GetElementSourcePosStr(LabelEl));
- end;
- writeln('CheckDirectReference failed: References:');
- for i:=0 to ReferenceElements.Count-1 do
- begin
- El:=TPasElement(ReferenceElements[i]);
- writeln(' Reference ',GetObjName(El),' at ',ResolverEngine.GetElementSourcePosStr(El));
- //if EL is TPasVariable then
- // writeln('CheckDirectReference ',GetObjPath(TPasVariable(El).VarType),' ',ResolverEngine.GetElementSourcePosStr(TPasVariable(EL).VarType));
- end;
- RaiseErrorAtSrcMarker('wrong direct reference "'+aMarker^.Identifier+'"',aMarker);
- finally
- LabelElements.Free;
- ReferenceElements.Free;
- end;
- end;
- var
- aMarker: PSrcMarker;
- i: Integer;
- SrcLines: TStringList;
- begin
- Module.ForEachCall(@OnCheckElementParent,nil);
- //writeln('TCustomTestModule.CheckReferenceDirectives find all markers');
- // find all markers
- for i:=0 to FileResolver.Streams.Count-1 do
- begin
- GetSrc(i,SrcLines,CurFilename);
- ParseCode(SrcLines,CurFilename);
- SrcLines.Free;
- end;
- //writeln('TCustomTestModule.CheckReferenceDirectives check references');
- // check references
- aMarker:=FirstSrcMarker;
- while aMarker<>nil do
- begin
- case aMarker^.Kind of
- mkResolverReference: CheckResolverReference(aMarker);
- mkDirectReference: CheckDirectReference(aMarker);
- end;
- aMarker:=aMarker^.Next;
- end;
- //writeln('TCustomTestModule.CheckReferenceDirectives COMPLETE');
- 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.RaiseErrorAtSrc(Msg: string;
- const aFilename: string; aRow, aCol: integer);
- var
- s: String;
- begin
- WriteSources(aFilename,aRow,aCol);
- s:='[TCustomTestModule.RaiseErrorAtSrc] '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+') Error: '+Msg;
- writeln('ERROR: ',s);
- Fail(s);
- end;
- procedure TCustomTestModule.RaiseErrorAtSrcMarker(Msg: string;
- aMarker: PSrcMarker);
- begin
- RaiseErrorAtSrc(Msg,aMarker^.Filename,aMarker^.Row,aMarker^.StartCol);
- 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;
- ResolverEngine.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 aFilename: string): integer;
- var
- i: Integer;
- begin
- for i:=0 to ResolverCount-1 do
- if aFilename=Resolvers[i].Filename then exit(i);
- Result:=-1;
- end;
- function TCustomTestModule.GetResolver(const aFilename: string
- ): TTestEnginePasResolver;
- var
- i: Integer;
- begin
- i:=IndexOfResolver(aFilename);
- if i<0 then exit(nil);
- Result:=Resolvers[i];
- end;
- procedure TCustomTestModule.GetSrc(Index: integer; out SrcLines: TStringList;
- out aFilename: string);
- var
- aStream: TStream;
- begin
- SrcLines:=TStringList.Create;
- aStream:=FileResolver.Streams.Objects[Index] as TStream;
- aStream.Position:=0;
- SrcLines.LoadFromStream(aStream);
- aFilename:=FileResolver.Streams[Index];
- end;
- function TCustomTestModule.FindElementsAt(aFilename: string; aLine, aStartCol,
- aEndCol: integer): TFPList;
- var
- ok: Boolean;
- FoundRefs: TTestResolverReferenceData;
- i: Integer;
- CurResolver: TTestEnginePasResolver;
- begin
- //writeln('TCustomTestModule.FindElementsAt START "',aFilename,'" Line=',aLine,' Col=',aStartCol,'-',aEndCol);
- FoundRefs:=Default(TTestResolverReferenceData);
- FoundRefs.Filename:=aFilename;
- FoundRefs.Row:=aLine;
- FoundRefs.StartCol:=aStartCol;
- FoundRefs.EndCol:=aEndCol;
- FoundRefs.Found:=TFPList.Create;
- ok:=false;
- try
- // find all markers
- Module.ForEachCall(@OnFindReference,@FoundRefs);
- for i:=0 to ResolverCount-1 do
- begin
- CurResolver:=Resolvers[i];
- if CurResolver.Module=Module then continue;
- //writeln('TCustomTestResolver.FindElementsAt ',CurResolver.Filename);
- CurResolver.Module.ForEachCall(@OnFindReference,@FoundRefs);
- end;
- ok:=true;
- finally
- if not ok then
- FreeAndNil(FoundRefs.Found);
- end;
- Result:=FoundRefs.Found;
- FoundRefs.Found:=nil;
- end;
- function TCustomTestModule.FindElementsAt(aMarker: PSrcMarker;
- ErrorOnNoElements: boolean): TFPList;
- begin
- Result:=FindElementsAt(aMarker^.Filename,aMarker^.Row,aMarker^.StartCol,aMarker^.EndCol);
- if ErrorOnNoElements and ((Result=nil) or (Result.Count=0)) then
- RaiseErrorAtSrcMarker('marker '+SrcMarker[aMarker^.Kind]+aMarker^.Identifier+' has no elements',aMarker);
- end;
- function TCustomTestModule.FindSrcLabel(const Identifier: string): PSrcMarker;
- begin
- Result:=FirstSrcMarker;
- while Result<>nil do
- begin
- if (Result^.Kind=mkLabel)
- and (CompareText(Result^.Identifier,Identifier)=0) then
- exit;
- Result:=Result^.Next;
- end;
- end;
- function TCustomTestModule.FindElementsAtSrcLabel(const Identifier: string;
- ErrorOnNoElements: boolean): TFPList;
- var
- SrcLabel: PSrcMarker;
- begin
- SrcLabel:=FindSrcLabel(Identifier);
- if SrcLabel=nil then
- Fail('missing label "'+Identifier+'"');
- Result:=FindElementsAt(SrcLabel,ErrorOnNoElements);
- 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:=ResolverEngine.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 = "\x00";',
- '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 = "\x00";',
- '']),
- 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 = "\x00";',
- '']),
- 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 >>> 0;',
- 'this.HiWord2 = Math.floor(-0x1234CDEF / 4294967296) >>> 0;',
- '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 Fly: string; external name ''fly'';',
- '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'';',
- ' s:=s+Fly+''e'';',
- ' s:=Fly+Fly+Fly;',
- '']);
- 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";',
- '$mod.s = $mod.s + fly() + "e";',
- '$mod.s = fly() + fly() + fly();',
- '']));
- 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 = "\x00";',
- ' 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_ResultAbsolute;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' Index: longint;',
- ' function DoAbs: pointer;',
- ' end;',
- 'function TObject.DoAbs: pointer;',
- 'var',
- ' o: TObject absolute Result;',
- 'begin',
- ' if o.Index<o.Index then o.Index:=o.Index;',
- 'end;',
- 'function DoIt: jsvalue;',
- 'var',
- ' d: double absolute Result;',
- ' s: string absolute Result;',
- ' o: TObject absolute Result;',
- 'begin',
- ' if d=d then d:=d;',
- ' if s=s then s:=s;',
- ' if o.Index<o.Index then o.Index:=o.Index;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestProc_ResultAbsolute',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Index = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoAbs = function () {',
- ' var Result = null;',
- ' if (Result.Index < Result.Index) Result.Index = Result.Index;',
- ' return Result;',
- ' };',
- '});',
- 'this.DoIt = function () {',
- ' var Result = undefined;',
- ' if (Result === Result) Result = Result;',
- ' if (Result === Result) Result = Result;',
- ' if (Result.Index < Result.Index) Result.Index = Result.Index;',
- ' return Result;',
- '};',
- '']),
- 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',
- ' Enum:=ord(1);',
- ' 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.Enum = 1;',
- '$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 = "\x00";',
- '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;',
- ' Inf = 1.0 / 0.0;',
- ' NegInf = -1.0 / 0.0;',
- 'procedure Run(d: double); external name ''Run'';',
- 'var',
- ' d: double = b;',
- 'begin',
- ' d:=1.0;',
- ' d:=1.0/3.0;',
- ' d:=1.0/(3-2-1);',
- ' 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:=100*9**0.5;',
- ' 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);',
- ' Run(Inf);',
- ' Run(NegInf);',
- '']);
- 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.Inf = 1.0 / 0.0;',
- 'this.NegInf = -1.0 / 0.0;',
- 'this.d = 4.4;',
- '']),
- LinesToStr([
- '$mod.d = 1.0;',
- '$mod.d = 1.0 / 3.0;',
- '$mod.d = 1.0 / (3 - 2 - 1);',
- '$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 = 10 ** 3;',
- '$mod.d = 100 * (9 ** 0.5);',
- '$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 = -3E-3;',
- '$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;',
- 'Run(1 / 0);',
- 'Run(-1 / 0);',
- '']));
- end;
- procedure TTestModule.TestDoubleSmall;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' a = 1e-1;',
- ' b = 1e-2;',
- ' c = 1e-3;',
- ' d = 1e-4;',
- ' e = 1e-5;',
- ' f = 1e-6;',
- ' g = 1e-7;',
- ' h = -1e-1;',
- ' i = -1e-2;',
- 'procedure Fly(d: double);',
- 'begin',
- 'end;',
- 'begin',
- ' Fly(a);',
- ' Fly(b);',
- ' Fly(c);',
- ' Fly(d);',
- ' Fly(e);',
- ' Fly(f);',
- ' Fly(g);',
- ' Fly(h);',
- ' Fly(i);',
- '']);
- ConvertProgram;
- CheckSource('TestDoubleSmall',
- LinesToStr([
- 'this.a = 1e-1;',
- 'this.b = 1e-2;',
- 'this.c = 1e-3;',
- 'this.d = 1e-4;',
- 'this.e = 1e-5;',
- 'this.f = 1e-6;',
- 'this.g = 1e-7;',
- 'this.h = -1e-1;',
- 'this.i = -1e-2;',
- 'this.Fly = function (d) {',
- '};',
- '']),
- LinesToStr([
- '$mod.Fly(0.1);',
- '$mod.Fly(0.01);',
- '$mod.Fly(1E-3);',
- '$mod.Fly(1E-4);',
- '$mod.Fly(1E-5);',
- '$mod.Fly(1E-6);',
- '$mod.Fly(1E-7);',
- '$mod.Fly(-0.1);',
- '$mod.Fly(-0.01);',
- '']));
- 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.TestInteger_AssignOutsideConst;
- begin
- StartProgram(false);
- Add([
- 'const',
- ' MinInt = low(longint);',
- ' MaxInt = high(longint);',
- 'type',
- ' {#TMyInt}TMyInt = MinInt..MaxInt;',
- 'var',
- ' i: TMyInt;',
- ' aByte: byte;',
- ' aShortInt: shortint;',
- ' aWord: word;',
- ' aSmallInt: smallint;',
- ' aLongWord: longword;',
- ' aLongInt: longint;',
- ' aNativeInt: nativeint;',
- ' aNativeUInt: nativeuint;',
- 'begin',
- ' aByte:=$FF;',
- ' aByte:=$100;',
- ' aByte:=-1;',
- ' aByte:=-127;',
- ' aByte:=-128;',
- ' aByte:=-254;',
- ' aByte:=-255;',
- ' aByte:=-256;',
- ' aShortInt:=127;',
- ' aShortInt:=128;',
- ' aShortInt:=-128;',
- ' aShortInt:=-129;',
- ' aWord:=$ffff;',
- ' aWord:=$10000;',
- ' aWord:=-1;',
- ' aWord:=-$ffff;',
- ' aWord:=-$10000;',
- ' aWord:=-$10001;',
- ' aSmallInt:=$7fff;',
- ' aSmallInt:=$8000;',
- ' aSmallInt:=-$8000;',
- ' aSmallInt:=-$8001;',
- ' aLongWord:=$ffffffff;',
- ' aLongWord:=$100000000;',
- ' aLongWord:=-1;',
- ' aLongWord:=-$ffffffff;',
- ' aNativeInt:=$1fffffffffffff;',
- ' aNativeInt:=-$1fffffffffffff;',
- ' aNativeUInt:=$1fffffffffffff;',
- ' aNativeUInt:=-$1fffffffffffff;',
- '']);
- ConvertProgram;
- CheckSource('TestInteger_AssignOutsideConst',
- LinesToStr([
- 'this.MinInt = -2147483648;',
- 'this.MaxInt = 2147483647;',
- 'this.i = 0;',
- 'this.aByte = 0;',
- 'this.aShortInt = 0;',
- 'this.aWord = 0;',
- 'this.aSmallInt = 0;',
- 'this.aLongWord = 0;',
- 'this.aLongInt = 0;',
- 'this.aNativeInt = 0;',
- 'this.aNativeUInt = 0;',
- '']),
- LinesToStr([
- '$mod.aByte = 0xFF;',
- '$mod.aByte = 0;',
- '$mod.aByte = 255;',
- '$mod.aByte = 129;',
- '$mod.aByte = 128;',
- '$mod.aByte = 2;',
- '$mod.aByte = 1;',
- '$mod.aByte = 0;',
- '$mod.aShortInt = 127;',
- '$mod.aShortInt = -128;',
- '$mod.aShortInt = -128;',
- '$mod.aShortInt = 127;',
- '$mod.aWord = 0xffff;',
- '$mod.aWord = 0;',
- '$mod.aWord = 65535;',
- '$mod.aWord = 1;',
- '$mod.aWord = 0;',
- '$mod.aWord = 65535;',
- '$mod.aSmallInt = 0x7fff;',
- '$mod.aSmallInt = -32768;',
- '$mod.aSmallInt = -0x8000;',
- '$mod.aSmallInt = 32767;',
- '$mod.aLongWord = 0xffffffff;',
- '$mod.aLongWord = 0;',
- '$mod.aLongWord = 4294967295;',
- '$mod.aLongWord = 1;',
- '$mod.aNativeInt = 0x1fffffffffffff;',
- '$mod.aNativeInt = -0x1fffffffffffff;',
- '$mod.aNativeUInt = 0x1fffffffffffff;',
- '$mod.aNativeUInt = 1;',
- '']));
- 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 = "\x00";',
- '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 = "\x00";',
- '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(''ö'');',
- ' f = low(a)+high(b);',
- ' g: word = low(a);',
- 'var',
- ' s: string = ''abc'';',
- ' i: longint;',
- '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;',
- ' i:=low(s)+high(a);',
- ' s:=''a/b'';',
- // ToDo: \uD87E\uDC04 -> \u{2F804}
- '']);
- ConvertProgram;
- CheckSource('TestStringConst',
- LinesToStr([
- 'this.a = "óż";',
- 'this.b = "a";',
- 'this.c = "ä";',
- 'this.d = "b";',
- 'this.e = "ö";',
- 'this.f = 1 + this.b.length;',
- 'this.g = 1;',
- 'this.s="abc";',
- 'this.i = 0;',
- '']),
- 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 = "úč";',
- '$mod.i = 1 + $mod.a.length;',
- '$mod.s = "a/b";',
- '']));
- 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
- ' s:=''Hello ''#55357#56841', // #$D83D#$DE09
- '']);
- ConvertProgram;
- CheckSource('TestStringConstSurrogate',
- LinesToStr([
- 'this.s="";'
- ]),
- LinesToStr([
- '$mod.s="😊";',
- '$mod.s="Hello 😉";'
- ]));
- end;
- procedure TTestModule.TestStringConstWhitespaces;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' s: string;',
- 'begin',
- ' s:=#$2028;', // line separator not supported by some editors, e.g. vsc
- ' s:=''Medium Mathematical Space ''#$205f',
- '']);
- ConvertProgram;
- CheckSource('TestStringConstSurrogate',
- LinesToStr([
- 'this.s="";'
- ]),
- LinesToStr([
- '$mod.s="\u2028";',
- '$mod.s="Medium Mathematical Space \u205F";'
- ]));
- end;
- procedure TTestModule.TestStringConst_Multiline;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch multilinestrings}',
- 'const',
- ' a = ``;',
- ' b = `',
- 'line`;',
- ' c = `Single`;',
- ' d = ````;',
- ' e = `abc``xyz`;',
- ' f = `first''line',
- ' second''line`#10;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestStringConst_Multiline',
- LinesToStr([
- 'this.a = "";',
- 'this.b = "'+JSONNewLine+'line";',
- 'this.c = "Single";',
- 'this.d = "`";',
- 'this.e = "abc`xyz";',
- 'this.f = "first''line'+JSONNewLine+' second''line\n";',
- '']),
- LinesToStr([
- ]));
- 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 Fly(var s: string);',
- 'begin',
- ' SetLength(s,1);',
- 'end;',
- 'procedure Run(var s: unicodestring);',
- 'begin',
- ' SetLength(s,2);',
- 'end;',
- 'var s: string;',
- ' u: unicodestring;',
- 'begin',
- ' SetLength(s,3);',
- ' SetLength(u,4);',
- '']);
- ConvertProgram;
- CheckSource('TestString_SetLength',
- LinesToStr([ // statements
- 'this.Fly = function (s) {',
- ' s.set(rtl.strSetLength(s.get(), 1));',
- '};',
- 'this.Run = function (s) {',
- ' s.set(rtl.strSetLength(s.get(), 2));',
- '};',
- 'this.s = "";',
- 'this.u = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.s = rtl.strSetLength($mod.s, 3);',
- '$mod.u = rtl.strSetLength($mod.u, 4);'
- ]));
- 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 = "\x00";',
- '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 = "\x00";',
- '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 = "\x00";',
- 'this.wc = "\x00";',
- '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 = "\x00";']),
- 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 = "\x00";',
- 'this.c2 = "\x00";',
- 'this.s = "";',
- 'this.a1 = [];',
- 'this.a2 = rtl.arraySetLength(null, "\x00", 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 = "\x00";',
- 'this.h = "\x00";',
- '']),
- 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, "\x00", 65536);',
- 'this.Arr2 = rtl.arraySetLength(null, "\x00", 26);',
- 'this.Arr3 = ["p", "a", "s"];',
- 'this.Arr4 = ["p", "a", "s"];',
- 'this.Arr5 = ["ä", "ö"];',
- 'this.Arr6 = ["ä", "ö"];',
- 'this.c = "\x00";',
- '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;',
- ' TArrayArrayArrayInt = array[7..8] of TArrayArrayInt;',
- ' TArrayDim2Int = array[1..2,1..3] of longint;',
- ' TArrayDim3Int = array[1..2,1..3,1..4] of longint;',
- ' TArrayDim4Int = array[1..2,1..3,1..4,1..5] of longint;',
- 'var',
- ' Arr: TArrayInt;',
- ' Arr2: TArrayArrayInt;',
- ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
- ' Arr4: TArrayArrayInt;',
- ' ArrDim2: TArrayDim2Int;',
- ' ArrDim3: TArrayDim3Int;',
- ' ArrDim4: TArrayDim4Int;',
- ' 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
- ' arr4:=arr4;',
- ' Arr:=Arr;',
- ' ArrDim2:=ArrDim2;',
- ' ArrDim3:=ArrDim3;',
- ' ArrDim4:=ArrDim4;',
- '']);
- ConvertProgram;
- CheckSource('TestArray_StaticMultiDim',
- LinesToStr([ // statements
- 'this.TArrayArrayInt$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = a[c].slice(0);',
- ' return b;',
- '};',
- 'this.TArrayArrayArrayInt$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = $mod.TArrayArrayInt$clone(a[c]);',
- ' return b;',
- '};',
- 'this.TArrayDim2Int$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = a[c].slice(0);',
- ' return b;',
- '};',
- 'this.TArrayDim3Int$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) {',
- ' var d = b[c] = [];',
- ' d.length = 3;',
- ' var e = a[c];',
- ' for (var f = 0; f < 3; f++) d[f] = e[f].slice(0);',
- ' };',
- ' return b;',
- '};',
- 'this.TArrayDim4Int$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) {',
- ' var d = b[c] = [];',
- ' d.length = 3;',
- ' var e = a[c];',
- ' for (var f = 0; f < 3; f++) {',
- ' var g = d[f] = [];',
- ' g.length = 4;',
- ' var h = e[f];',
- ' for (var i = 0; i < 4; i++) g[i] = h[i].slice(0);',
- ' };',
- ' };',
- ' return b;',
- '};',
- 'this.Arr = rtl.arraySetLength(null, 0, 3);',
- 'this.Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
- 'this.Arr3$a$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = a[c].slice(0);',
- ' return b;',
- '};',
- 'this.Arr3 = [[11, 12, 13], [21, 22, 23]];',
- 'this.Arr4 = rtl.arraySetLength(null, 0, 2, 3);',
- 'this.ArrDim2 = rtl.arraySetLength(null, 0, 2, 3);',
- 'this.ArrDim3 = rtl.arraySetLength(null, 0, 2, 3, 4);',
- 'this.ArrDim4 = rtl.arraySetLength(',
- ' null,',
- ' 0,',
- ' 2,',
- ' 3,',
- ' 4,',
- ' 5',
- ');',
- '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);',
- '$mod.Arr4 = $mod.TArrayArrayInt$clone($mod.Arr4);',
- '$mod.Arr = $mod.Arr.slice(0);',
- '$mod.ArrDim2 = $mod.TArrayDim2Int$clone($mod.ArrDim2);',
- '$mod.ArrDim3 = $mod.TArrayDim3Int$clone($mod.ArrDim3);',
- '$mod.ArrDim4 = $mod.TArrayDim4Int$clone($mod.ArrDim4);',
- '']));
- 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 b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = a[c].slice(0);',
- ' return b;',
- '};',
- 'var Arr3$a$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = a[c].slice(0);',
- ' return b;',
- '};',
- '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 b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = $mod.TRec.$clone(a[c]);',
- ' return b;',
- '};',
- '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 = "\x00";',
- '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',
- ' ArrInt1, ArrInt2: tarrint;',
- ' ArrRec1, ArrRec2: tarrrec;',
- ' ArrFlag1, ArrFlag2: tarrflag;',
- ' ArrSet1, ArrSet2: tarrset;',
- ' ArrJSValue1, ArrJSValue2: tarrjsvalue;',
- 'begin',
- ' arrint1:=concat(arrint2);',
- ' arrint1:=concat(arrint2,arrint2);',
- ' arrint1:=concat(arrint2,arrint2,arrint2);',
- ' arrrec1:=concat(arrrec2);',
- ' arrrec1:=concat(arrrec2,arrrec2);',
- ' arrrec1:=concat(arrrec2,arrrec2,arrrec2);',
- ' arrset1:=concat(arrset2);',
- ' arrset1:=concat(arrset2,arrset2);',
- ' arrset1:=concat(arrset2,arrset2,arrset2);',
- ' arrjsvalue1:=concat(arrjsvalue2);',
- ' arrjsvalue1:=concat(arrjsvalue2,arrjsvalue2);',
- ' arrjsvalue1:=concat(arrjsvalue2,arrjsvalue2,arrjsvalue2);',
- ' arrint1:=concat([1],arrint2);',
- ' arrflag1:=concat([big]);',
- ' arrflag1:=concat([big],arrflag2);',
- ' arrflag1:=concat(arrflag2,[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.ArrInt1 = [];',
- 'this.ArrInt2 = [];',
- 'this.ArrRec1 = [];',
- 'this.ArrRec2 = [];',
- 'this.ArrFlag1 = [];',
- 'this.ArrFlag2 = [];',
- 'this.ArrSet1 = [];',
- 'this.ArrSet2 = [];',
- 'this.ArrJSValue1 = [];',
- 'this.ArrJSValue2 = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ArrInt1 = rtl.arrayRef($mod.ArrInt2);',
- '$mod.ArrInt1 = rtl.arrayConcatN($mod.ArrInt2, $mod.ArrInt2);',
- '$mod.ArrInt1 = rtl.arrayConcatN($mod.ArrInt2, $mod.ArrInt2, $mod.ArrInt2);',
- '$mod.ArrRec1 = rtl.arrayRef($mod.ArrRec2);',
- '$mod.ArrRec1 = rtl.arrayConcat($mod.TRec, $mod.ArrRec2, $mod.ArrRec2);',
- '$mod.ArrRec1 = rtl.arrayConcat($mod.TRec, $mod.ArrRec2, $mod.ArrRec2, $mod.ArrRec2);',
- '$mod.ArrSet1 = rtl.arrayRef($mod.ArrSet2);',
- '$mod.ArrSet1 = rtl.arrayConcat("refSet", $mod.ArrSet2, $mod.ArrSet2);',
- '$mod.ArrSet1 = rtl.arrayConcat("refSet", $mod.ArrSet2, $mod.ArrSet2, $mod.ArrSet2);',
- '$mod.ArrJSValue1 = rtl.arrayRef($mod.ArrJSValue2);',
- '$mod.ArrJSValue1 = rtl.arrayConcatN($mod.ArrJSValue2, $mod.ArrJSValue2);',
- '$mod.ArrJSValue1 = rtl.arrayConcatN($mod.ArrJSValue2, $mod.ArrJSValue2, $mod.ArrJSValue2);',
- '$mod.ArrInt1 = rtl.arrayConcatN([1], $mod.ArrInt2);',
- '$mod.ArrFlag1 = [$mod.TFlag.big];',
- '$mod.ArrFlag1 = rtl.arrayConcatN([$mod.TFlag.big], $mod.ArrFlag2);',
- '$mod.ArrFlag1 = rtl.arrayConcatN($mod.ArrFlag2, [$mod.TFlag.small]);',
- '']));
- end;
- procedure TTestModule.TestArray_Concat_Append;
- 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;',
- ' r: TRec;',
- ' f: TFlags;',
- 'begin',
- ' // append',
- ' arrint:=concat(arrint);',
- ' arrint:=concat(arrint,[2]);',
- ' arrint:=concat(arrint,[3,4]);',
- ' arrrec:=concat(arrrec);',
- ' arrrec:=concat(arrrec,[r]);',
- ' arrrec:=concat(arrrec,[r,r]);',
- ' arrset:=concat(arrset);',
- ' arrset:=concat(arrset,[f]);',
- ' arrset:=concat(arrset,[f,f]);',
- ' arrjsvalue:=concat(arrjsvalue);',
- ' arrjsvalue:=concat(arrjsvalue,[11]);',
- ' arrjsvalue:=concat(arrjsvalue,[12,13]);',
- ' arrflag:=concat(arrflag);',
- ' arrflag:=concat(arrflag,[small]);',
- ' arrflag:=concat(arrflag,[small,big]);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_Concat_Append',
- 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 = [];',
- 'this.r = this.TRec.$new();',
- 'this.f = {};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ArrInt = $mod.ArrInt;',
- '$mod.ArrInt = rtl.arrayPushN($mod.ArrInt, 2);',
- '$mod.ArrInt = rtl.arrayPushN($mod.ArrInt, 3, 4);',
- '$mod.ArrRec = $mod.ArrRec;',
- '$mod.ArrRec = rtl.arrayPush($mod.TRec, $mod.ArrRec, $mod.r);',
- '$mod.ArrRec = rtl.arrayPush($mod.TRec, $mod.ArrRec, $mod.r, $mod.r);',
- '$mod.ArrSet = $mod.ArrSet;',
- '$mod.ArrSet = rtl.arrayPush("refSet", $mod.ArrSet, $mod.f);',
- '$mod.ArrSet = rtl.arrayPush("refSet", $mod.ArrSet, $mod.f, $mod.f);',
- '$mod.ArrJSValue = $mod.ArrJSValue;',
- '$mod.ArrJSValue = rtl.arrayPushN($mod.ArrJSValue, 11);',
- '$mod.ArrJSValue = rtl.arrayPushN($mod.ArrJSValue, 12, 13);',
- '$mod.ArrFlag = $mod.ArrFlag;',
- '$mod.ArrFlag = rtl.arrayPushN($mod.ArrFlag, $mod.TFlag.small);',
- '$mod.ArrFlag = rtl.arrayPushN($mod.ArrFlag, $mod.TFlag.small, $mod.TFlag.big);',
- '']));
- end;
- procedure TTestModule.TestArray_Concat_Append_Var;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TArrInt = array of word;',
- '',
- 'procedure Fly(a: TArrInt; var b: TArrInt);',
- 'begin',
- ' a:=concat(a,[2]);',
- ' b:=concat(b,[2]);',
- 'end;',
- 'var',
- ' ArrInt: tarrint;',
- 'begin',
- ' Fly(ArrInt,ArrInt);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_Concat_Append_Var',
- LinesToStr([ // statements
- 'this.Fly = function (a, b) {',
- ' a = rtl.arrayPushN(a, 2);',
- ' b.set(rtl.arrayPushN(b.get(), 2));',
- '};',
- 'this.ArrInt = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Fly(rtl.arrayRef($mod.ArrInt), {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.ArrInt;',
- ' },',
- ' set: function (v) {',
- ' this.p.ArrInt = v;',
- ' }',
- '});',
- '']));
- 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_Add_Append;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch arrayoperators}',
- '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;',
- ' r: TRec;',
- ' f: TFlags;',
- 'begin',
- ' // append',
- ' arrint:=arrint+[2];',
- ' arrint:=arrint+[3,4];',
- ' arrrec:=arrrec+[r];',
- ' arrrec:=arrrec+[r,r];',
- ' arrset:=arrset+[f];',
- ' arrset:=arrset+[f,f];',
- ' arrjsvalue:=arrjsvalue+[11];',
- ' arrjsvalue:=arrjsvalue+[12,13];',
- ' arrflag:=arrflag+[small];',
- ' arrflag:=arrflag+[small,big];',
- '']);
- ConvertProgram;
- CheckSource('TestArray_Add_Append',
- 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 = [];',
- 'this.r = this.TRec.$new();',
- 'this.f = {};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ArrInt = rtl.arrayPushN($mod.ArrInt, 2);',
- '$mod.ArrInt = rtl.arrayPushN($mod.ArrInt, 3, 4);',
- '$mod.ArrRec = rtl.arrayPush($mod.TRec, $mod.ArrRec, $mod.r);',
- '$mod.ArrRec = rtl.arrayPush($mod.TRec, $mod.ArrRec, $mod.r, $mod.r);',
- '$mod.ArrSet = rtl.arrayPush("refSet", $mod.ArrSet, $mod.f);',
- '$mod.ArrSet = rtl.arrayPush("refSet", $mod.ArrSet, $mod.f, $mod.f);',
- '$mod.ArrJSValue = rtl.arrayPushN($mod.ArrJSValue, 11);',
- '$mod.ArrJSValue = rtl.arrayPushN($mod.ArrJSValue, 12, 13);',
- '$mod.ArrFlag = rtl.arrayPushN($mod.ArrFlag, $mod.TFlag.small);',
- '$mod.ArrFlag = rtl.arrayPushN($mod.ArrFlag, $mod.TFlag.small, $mod.TFlag.big);',
- '']));
- 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 = $mod.Ints;',
- '$mod.Ints = rtl.arrayConcatN($mod.Ints, $mod.OneInt);',
- '$mod.Ints = rtl.arrayPushN($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.arrayPushN($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.arrayConcat("slice", a, [[1, 2]]));',
- ' $mod.DoInt(rtl.arrayConcat("slice", [[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.arrayPush("slice", $mod.a, $mod.i);',
- '$mod.a = rtl.arrayConcat("slice", [$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);',
- ' aObj:=TJSArray([''bird'',''ant'']);',
- '']);
- 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;',
- '$mod.aObj = ["bird", "ant"];',
- '']));
- 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('Not supported: variant record',
- nNotSupportedX);
- 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.m$a$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = a[c].slice(0);',
- ' return b;',
- ' };',
- ' 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 = this.m$a$clone(s.m);',
- ' 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.m$a$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = a[c].slice(0);',
- ' return b;',
- ' };',
- ' 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 = this.m$a$clone(s.m);',
- ' 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_ArrayConstMultiline;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'type',
- ' TBird = record Wing: string; end;',
- 'const',
- ' Birds: array[1..2] of TBird = (',
- ' (Wing: ''''''',
- ' First',
- ' Second',
- ' Third',
- ' ''''''),',
- ' (Wing: ''''''',
- ' Value:=''Im in quotes''; ',
- ' '''''')',
- ' );',
- 'begin']);
- ConvertProgram;
- CheckSource('TestRecord_ArrayConstMultiline',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "TBird", function () {',
- ' this.Wing = "";',
- ' this.$eq = function (b) {',
- ' return this.Wing === b.Wing;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Wing = s.Wing;',
- ' return this;',
- ' };',
- '});',
- 'this.Birds$a$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = $mod.TBird.$clone(a[c]);',
- ' return b;',
- '};',
- 'this.Birds = [this.TBird.$clone({',
- ' Wing: " First\n Second\n Third"',
- '}), this.TBird.$clone({',
- ' Wing: " Value:=''Im in quotes''; "',
- '})];',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRecordAnonym_Field;
- begin
- StartProgram(false);
- Add(['',
- 'var Rec: record',
- ' Bold: longint;',
- ' end;',
- 'begin',
- ' rec.bold:=123;',
- ' rec.bold:=rec.bold+7;',
- '']);
- ConvertProgram;
- CheckSource('TestRecordAnonym_Field',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "Rec$a", 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.Rec$a.$new();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Rec.Bold = 123;',
- '$mod.Rec.Bold = $mod.Rec.Bold + 7;',
- '']));
- end;
- procedure TTestModule.TestRecordAnonym_Assign;
- begin
- StartProgram(false);
- Add(['',
- 'var S,T: record',
- ' Bold: longint;',
- ' end;',
- ' b: boolean;',
- 'begin',
- ' S:=T;',
- ' b:=s=t;',
- '']);
- ConvertProgram;
- CheckSource('TestRecordAnonym_Assign',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "T$a", function () {',
- ' this.Bold = 0;',
- ' this.$eq = function (b) {',
- ' return this.Bold === b.Bold;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Bold = s.Bold;',
- ' return this;',
- ' };',
- '});',
- 'this.S = this.T$a.$new();',
- 'this.T = this.T$a.$new();',
- 'this.b = false;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.S.$assign($mod.T);',
- '$mod.b = $mod.S.$eq($mod.T);',
- '']));
- end;
- procedure TTestModule.TestRecordAnonym_Nested;
- begin
- StartProgram(false);
- Add(['',
- 'var S,T: record',
- ' Bold: longint;',
- ' Sub: record',
- ' Color: word;',
- ' end;',
- ' end;',
- ' b: boolean;',
- 'begin',
- ' S:=T;',
- ' S.Sub:=T.Sub;',
- ' S.Sub.Color:=T.Sub.Color+3;',
- ' b:=s=t;',
- ' b:=s.Sub=t.Sub;',
- '']);
- ConvertProgram;
- CheckSource('TestRecordAnonym_Nested',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "T$a", function () {',
- ' this.Bold = 0;',
- ' rtl.recNewT(this, "Sub$a", function () {',
- ' this.Color = 0;',
- ' this.$eq = function (b) {',
- ' return this.Color === b.Color;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Color = s.Color;',
- ' return this;',
- ' };',
- ' });',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.Sub = this.Sub$a.$new();',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.Bold === b.Bold) && this.Sub.$eq(b.Sub);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Bold = s.Bold;',
- ' this.Sub.$assign(s.Sub);',
- ' return this;',
- ' };',
- '}, true);',
- 'this.S = this.T$a.$new();',
- 'this.T = this.T$a.$new();',
- 'this.b = false;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.S.$assign($mod.T);',
- '$mod.S.Sub.$assign($mod.T.Sub);',
- '$mod.S.Sub.Color = $mod.T.Sub.Color + 3;',
- '$mod.b = $mod.S.$eq($mod.T);',
- '$mod.b = $mod.S.Sub.$eq($mod.T.Sub);',
- '']));
- end;
- procedure TTestModule.TestRecordAnonym_Const;
- begin
- StartProgram(false);
- Add(['',
- 'var T: record',
- ' Bold: longint;',
- ' Sub: record',
- ' Color: word;',
- ' end;',
- ' end = (Bold: 2; Sub: (Color: 3));',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestRecordAnonym_Const',
- LinesToStr([ // statements
- 'rtl.recNewT(this, "T$a", function () {',
- ' this.Bold = 0;',
- ' rtl.recNewT(this, "Sub$a", function () {',
- ' this.Color = 0;',
- ' this.$eq = function (b) {',
- ' return this.Color === b.Color;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Color = s.Color;',
- ' return this;',
- ' };',
- ' });',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.Sub = this.Sub$a.$new();',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.Bold === b.Bold) && this.Sub.$eq(b.Sub);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Bold = s.Bold;',
- ' this.Sub.$assign(s.Sub);',
- ' return this;',
- ' };',
- '}, true);',
- 'this.T = this.T$a.$clone({',
- ' Bold: 2,',
- ' Sub: this.T$a.Sub$a.$clone({',
- ' Color: 3',
- ' })',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRecordAnonym_InFunction;
- begin
- StartProgram(false);
- Add(['',
- 'procedure Fly;',
- 'var T: record',
- ' Bold: longint;',
- ' Sub: record',
- ' Color: word;',
- ' end;',
- ' end = (Bold: 2; Sub: (Color: 3));',
- 'begin',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestRecordAnonym_InFunction',
- LinesToStr([ // statements
- 'var T$a = rtl.recNewT(null, "", function () {',
- ' this.Bold = 0;',
- ' rtl.recNewT(this, "Sub$a", function () {',
- ' this.Color = 0;',
- ' this.$eq = function (b) {',
- ' return this.Color === b.Color;',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Color = s.Color;',
- ' return this;',
- ' };',
- ' });',
- ' this.$new = function () {',
- ' var r = Object.create(this);',
- ' r.Sub = this.Sub$a.$new();',
- ' return r;',
- ' };',
- ' this.$eq = function (b) {',
- ' return (this.Bold === b.Bold) && this.Sub.$eq(b.Sub);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Bold = s.Bold;',
- ' this.Sub.$assign(s.Sub);',
- ' return this;',
- ' };',
- '}, true);',
- 'this.Fly = function () {',
- ' var T = T$a.$clone({',
- ' Bold: 2,',
- ' Sub: T$a.Sub$a.$clone({',
- ' Color: 3',
- ' })',
- ' });',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- 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.m$a$clone = function (a) {',
- ' var b = [];',
- ' b.length = 2;',
- ' for (var c = 0; c < 2; c++) b[c] = a[c].slice(0);',
- ' return b;',
- ' };',
- ' 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 = this.m$a$clone(s.m);',
- ' 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_ClassMethodStatic;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' class function GetInt: longint; static;',
- ' class procedure SetInt(Value: longint); static;',
- ' class function GetItems(Index: word): longint; static;',
- ' class procedure SetItems(Index: word; const Value: longint); static;',
- ' end;',
- ' TBird = class',
- ' class procedure Fly;',
- ' class property IntA: longint read GetInt write SetInt;',
- ' class property Items[Index: word]: longint read GetItems write SetItems;',
- ' end;',
- 'class function tobject.getint: longint;',
- 'begin',
- 'end;',
- 'class procedure tobject.setint(value: longint);',
- 'begin',
- 'end;',
- 'class function tobject.GetItems(Index: word): longint;',
- 'begin',
- 'end;',
- 'class procedure TObject.SetItems(Index: word; const Value: longint);',
- 'begin',
- 'end;',
- 'class procedure tbird.fly;',
- 'var w: longint;',
- 'begin',
- ' inta:=inta+51;',
- ' w:=items[52];',
- ' items[53]:=54;',
- 'end;',
- 'var Obj: tbird;',
- ' i: longint;',
- 'begin',
- ' tbird.inta:=tbird.inta+1;',
- ' i:=tbird.items[2];',
- ' tbird.items[3]:=4;',
- ' obj.inta:=obj.inta+11;',
- ' i:=obj.items[12];',
- ' obj.items[13]:=14;',
- ' with Tbird do begin',
- ' inta:=inta+21;',
- ' i:=items[22];',
- ' items[23]:=24;',
- ' end;',
- ' with Obj do begin',
- ' inta:=inta+31;',
- ' i:=items[32];',
- ' items[33]:=34;',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestClass_Property_ClassMethod',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.GetInt = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetInt = function (Value) {',
- ' };',
- ' this.GetItems = function (Index) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Fly = function () {',
- ' var w = 0;',
- ' this.SetInt(this.GetInt() + 51);',
- ' w = this.GetItems(52);',
- ' this.SetItems(53, 54);',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.i = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.TObject.SetInt($mod.TObject.GetInt() + 1);',
- '$mod.i = $mod.TObject.GetItems(2);',
- '$mod.TObject.SetItems(3, 4);',
- '$mod.TObject.SetInt($mod.TObject.GetInt() + 11);',
- '$mod.i = $mod.TObject.GetItems(12);',
- '$mod.TObject.SetItems(13, 14);',
- 'var $with = $mod.TBird;',
- '$with.SetInt($with.GetInt() + 21);',
- '$mod.i = $with.GetItems(22);',
- '$with.SetItems(23, 24);',
- 'var $with1 = $mod.Obj;',
- '$with1.SetInt($with1.GetInt() + 31);',
- '$mod.i = $with1.GetItems(32);',
- '$with1.SetItems(33, 34);',
- '']));
- 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',
- ' {$DispatchField DispInt}',
- ' {$DispatchStrField DispStr}',
- ' TObject = class',
- ' procedure Dispatch(var Msg); virtual; abstract;',
- ' 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;
- CheckResolverUnexpectedHints(true);
- 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',
- ' 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
- 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.TestNestedClass_CallInherited;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- ' TBird = class',
- ' type',
- ' TWing = class',
- ' function Fly(w: word = 17): word; virtual;',
- ' end;',
- ' end;',
- ' TEagle = class(TBird)',
- ' type',
- ' TEagleWing = class(TWing)',
- ' function Fly(w: word): word; override;',
- ' end;',
- ' end;',
- 'function TBird.TWing.Fly(w: word): word;',
- 'begin',
- 'end;',
- 'function TEagle.TEagleWing.Fly(w: word): word;',
- 'begin',
- ' inherited;',
- ' inherited Fly;',
- ' inherited Fly(3);',
- ' Result:=inherited Fly;',
- ' Result:=inherited Fly(4);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestNestedClass_CallInherited',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' rtl.createClass(this, "TWing", $mod.TObject, function () {',
- ' this.Fly = function (w) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' }, "TBird.TWing");',
- '});',
- 'rtl.createClass(this, "TEagle", this.TBird, function () {',
- ' rtl.createClass(this, "TEagleWing", this.TWing, function () {',
- ' this.Fly = function (w) {',
- ' var Result = 0;',
- ' $mod.TBird.TWing.Fly.apply(this, arguments);',
- ' $mod.TBird.TWing.Fly.call(this, 17);',
- ' $mod.TBird.TWing.Fly.call(this, 3);',
- ' Result = $mod.TBird.TWing.Fly.call(this, 17);',
- ' Result = $mod.TBird.TWing.Fly.call(this, 4);',
- ' return Result;',
- ' };',
- ' }, "TEagle.TEagleWing");',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- 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, 4);',
- ' $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''',
- ' public type',
- ' TExtB = class external name ''ExtB''',
- ' public type',
- ' TExtC = class external name ''ExtC''',
- ' constructor New;',
- ' constructor New(i: word);',
- ' end;',
- ' end;',
- ' constructor Create;',
- ' constructor Create(i: longint; j: longint = 2);',
- ' end;',
- 'var',
- ' A: texta;',
- ' C: texta.textb.textc;',
- '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);',
- ' c:=texta.textb.textc.new;',
- ' c:=texta.textb.textc.new();',
- ' c:=texta.textb.textc.new(4);',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_Constructor',
- LinesToStr([ // statements
- 'this.A = null;',
- 'this.C = 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);',
- '$mod.C = new ExtA.ExtB.ExtC();',
- '$mod.C = new ExtA.ExtB.ExtC();',
- '$mod.C = new ExtA.ExtB.ExtC(4);',
- '']));
- 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 for 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 for 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;',
- ' TExtString = class external name ''String''',
- ' function charAt(aIndex : NativeInt) : string;',
- ' end;',
- 'var',
- ' Obj: TObject;',
- ' Child: TChild;',
- ' RootA: TExtRootA;',
- ' ChildA: TExtChildA;',
- ' RootB: TExtRootB;',
- ' ChildB: TExtChildB;',
- ' i: IUnknown;',
- ' s: string;',
- ' v: jsvalue;',
- '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);',
- ' s:=TExtString(s).charAt(7);',
- ' s:=TExtString(v).charAt(8);',
- '']);
- 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;',
- 'this.s = "";',
- 'this.v = undefined;',
- '']),
- 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;',
- '$mod.s = $mod.s.charAt(7);',
- '$mod.s = $mod.v.charAt(8);',
- '']));
- 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 for arg no. 1: Got "unit3.TJSBufferSource", expected "unit2.TJSBufferSource"',
- nIncompatibleTypeArgNo);
- ConvertUnit;
- end;
- procedure TTestModule.TestExternalClass_NestedConstructor;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TJSObject = class external name ''Object''',
- ' type TBird = class external name ''Bird''',
- ' type TWing = class external name ''Wing''',
- ' constructor New;',
- ' constructor Create(w: word = 3);',
- ' end;',
- ' end;',
- ' end;',
- 'var',
- ' w: TJSObject.TBird.TWing;',
- 'begin',
- ' w:=tjsobject.tbird.twing.new;',
- ' w:=tjsobject.tbird.twing.new();',
- ' w:=tjsobject.tbird.twing.create;',
- ' w:=tjsobject.tbird.twing.create(4);',
- ' with tjsobject do begin',
- ' w:=tbird.twing.new;',
- ' w:=tbird.twing.new();',
- ' w:=tbird.twing.create;',
- ' w:=tbird.twing.create(11);',
- ' end;',
- ' with tjsobject.tbird do begin',
- ' w:=twing.new;',
- ' w:=twing.new();',
- ' w:=twing.create;',
- ' w:=twing.create(21);',
- ' end;',
- ' with tjsobject.tbird.twing do begin',
- ' w:=new;',
- ' w:=new();',
- ' w:=create;',
- ' w:=create(31);',
- ' end;',
- '']);
- ConvertProgram;
- CheckSource('TestExternalClass_NestedConstructor',
- LinesToStr([ // statements
- 'this.w = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.w = new Object.Bird.Wing();',
- '$mod.w = new Object.Bird.Wing();',
- '$mod.w = new Object.Bird.Wing.Create();',
- '$mod.w = new Object.Bird.Wing.Create(4);',
- '$mod.w = new Object.Bird.Wing();',
- '$mod.w = new Object.Bird.Wing();',
- '$mod.w = new Object.Bird.Wing.Create();',
- '$mod.w = new Object.Bird.Wing.Create(11);',
- 'var $with = Object.Bird;',
- '$mod.w = new Object.Bird.Wing();',
- '$mod.w = new Object.Bird.Wing();',
- '$mod.w = new Object.Bird.Wing.Create();',
- '$mod.w = new Object.Bird.Wing.Create(21);',
- 'var $with1 = Object.Bird.Wing;',
- '$mod.w = new $with1();',
- '$mod.w = new $with1();',
- '$mod.w = new Object.Bird.Wing.Create();',
- '$mod.w = new Object.Bird.Wing.Create(31);',
- '']));
- 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_Corba_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_Corba_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_Corba_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_Corba_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_Corba_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_Corba_AncestorImpl',
- 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_Corba_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_Corba_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_Corba_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_Corba_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_COM_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_AncestorMoreInterfaces',
- 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_Corba_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_Corba_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_Corba_ArrayOfIntf;
- begin
- StartProgram(false);
- Add([
- '{$interfaces corba}',
- 'type',
- ' IUnknown = interface end;',
- ' IBird = interface(IUnknown)',
- ' function Fly(w: word): word;',
- ' end;',
- ' TBirdArray = array of IBird;',
- 'var',
- ' i: IBird;',
- ' a: TBirdArray;',
- 'begin',
- ' SetLength(a,3);',
- ' i:=a[1];',
- ' a[2]:=i;',
- ' for i in a do i.fly(3);',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Corba_ArrayOfIntf',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], this.IUnknown);',
- 'this.i = null;',
- 'this.a = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.a = rtl.arraySetLength($mod.a, null, 3);',
- '$mod.i = $mod.a[1];',
- '$mod.a[2] = $mod.i;',
- 'for (var $in = $mod.a, $l = 0, $end = rtl.length($in) - 1; $l <= $end; $l++) {',
- ' $mod.i = $in[$l];',
- ' $mod.i.Fly(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_FunctionExit;
- 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;',
- ' constructor Create;',
- ' end;',
- 'constructor TObject.Create;',
- 'begin',
- 'end;',
- 'function GetIntf: IUnknown;',
- 'var Intf: IUnknown;',
- 'begin',
- ' Intf := TObject.Create;',
- ' Exit(Intf);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_FunctionExit',
- 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.Create = function () {',
- ' return this;',
- ' };',
- ' rtl.addIntf(this, $mod.IUnknown);',
- '});',
- 'this.GetIntf = function () {',
- ' var Result = null;',
- ' var Intf = null;',
- ' var $ok = false;',
- ' try {',
- ' Intf = rtl.setIntfL(Intf, rtl.queryIntfT($mod.TObject.$create("Create"), $mod.IUnknown), true);',
- ' $ok = true;',
- ' Result = rtl.setIntfL(Result, Intf);',
- ' return Result;',
- ' $ok = true;',
- ' } finally {',
- ' rtl._Release(Intf);',
- ' if (!$ok) rtl._Release(Result);',
- ' };',
- ' return Result;',
- '};',
- '']),
- 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 () {',
- ' rtl.setIntfP(this, "FAnt", null);',
- ' };',
- ' 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 () {',
- ' rtl.setIntfP(this, "FBirdIntf", null);',
- ' 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_ForObjectInInterface;
- 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_ForObjectInInterface',
- 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_ForInterfaceInObject;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface end;',
- ' TObject = class',
- ' end;',
- ' IWing = interface',
- ' function Id: longint;',
- ' end;',
- ' TEnumerator = class',
- ' function GetCurrent: IWing; virtual; abstract;',
- ' function MoveNext: Boolean; virtual; abstract;',
- ' property Current: IWing read GetCurrent;',
- ' end;',
- ' TBird = class',
- ' function GetEnumerator: TEnumerator; virtual; abstract;',
- ' procedure Test;',
- ' end;',
- 'procedure TBird.Test;',
- 'var',
- ' Wing: IWing;',
- 'begin',
- ' for Wing in Self do',
- ' if Wing.Id=1 then ;',
- 'end;',
- 'var',
- ' Bird: TBird;',
- ' Wing: IWing;',
- 'begin',
- ' for Wing in Bird do',
- ' if Wing.Id=2 then ;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ForInterfaceInObject',
- 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.createInterface(this, "IWing", "{8B0D080B-C0F6-396E-AE88-000BDB74730C}", ["Id"], this.IUnknown);',
- 'rtl.createClass(this, "TEnumerator", this.TObject, function () {',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Test = function () {',
- ' var Wing = null;',
- ' try {',
- ' var $in = this.GetEnumerator();',
- ' try {',
- ' while ($in.MoveNext()) {',
- ' Wing = rtl.setIntfL(Wing, $in.GetCurrent(), true);',
- ' if (Wing.Id() === 1) ;',
- ' }',
- ' } finally {',
- ' $in = rtl.freeLoc($in)',
- ' };',
- ' } finally {',
- ' rtl._Release(Wing);',
- ' };',
- ' };',
- '});',
- 'this.Bird = null;',
- 'this.Wing = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'var $in = $mod.Bird.GetEnumerator();',
- 'try {',
- ' while ($in.MoveNext()) {',
- ' rtl.setIntfP($mod, "Wing", $in.GetCurrent(), true);',
- ' if ($mod.Wing.Id() === 2) ;',
- ' }',
- '} finally {',
- ' $in = rtl.freeLoc($in)',
- '};',
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf;
- begin
- {$IFNDEF EnableCOMArrayOfIntf}
- exit;
- {$ENDIF}
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface end;',
- ' IBird = interface(IUnknown)',
- ' function Fly(w: word): word;',
- ' end;',
- ' TBirdArray = array of IBird;',
- 'procedure Run;',
- 'var',
- ' i: IBird;',
- ' a,b: TBirdArray;',
- 'begin',
- //' SetLength(a,3);',
- ' a:=b;',
- ' i:=a[1];',
- ' a[2]:=i;',
- //' for i in a do i.fly(3);',
- // a:=copy(b,1,2);
- // a:=concat(b,a);
- // insert(i,b,1);
- // a:=[i,i];
- 'end;',
- // ToDo: pass TBirdArray as arg
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], this.IUnknown);',
- 'this.Run = function () {',
- ' var i = null;',
- ' var a = [];',
- ' var b = [];',
- ' try {',
- ' a = rtl.arrayRef(b);',
- ' i = rtl.setIntfL(i, a[1]);',
- ' rtl.setIntfP(a, 2, i);',
- ' } finally {',
- ' rtl._Release(i);',
- ' rtl._ReleaseArray(a,1);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- 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_Corba_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_Corba_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_Corba_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);',
- ' Self:=Concat(Self,[true]);',
- '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.set(rtl.arrayPushN(this.get(), true));',
- ' };',
- '});',
- '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.TestProcType_SafeCall_Arg;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TSafecallProc = reference to procedure; safecall;',
- 'procedure Fly(const aHandler: TSafecallProc);',
- 'var',
- ' P: TSafecallProc;',
- 'begin',
- ' P := aHandler;',
- ' Fly(P);',
- ' Fly(aHandler);',
- 'end;',
- 'begin',
- ' Fly(nil);',
- '']);
- ConvertProgram;
- CheckSource('TestProcType_SafeCall_Arg',
- LinesToStr([ // statements
- 'this.Fly = function (aHandler) {',
- ' var P = null;',
- ' P = aHandler;',
- ' $mod.Fly(P);',
- ' $mod.Fly(aHandler);',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Fly(null);',
- '']));
- 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',
- '']);
- SetExpectedParserError('Parameters or result types cannot contain local type definitions. Use a separate type definition in a type block. at token "^" in file test1.pp at line 3 column 19',nParserParamsOrResultTypesNoLocalTypeDefs);
- 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',
- '']);
- SetExpectedParserError('Parameters or result types cannot contain local type definitions. Use a separate type definition in a type block. at token "^" in file test1.pp at line 3 column 16',nParserParamsOrResultTypesNoLocalTypeDefs);
- 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 for 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 = "\x00";',
- '']),
- 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 = "\x00";',
- '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 = "\x00";',
- '']),
- 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 = "\x00";',
- '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 = "\x00";',
- '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([])',
- '});',
- 'this.$rtti.$MethodVar("TMethodB", {',
- ' procsig: rtl.newTIProcSig([]),',
- ' 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([], 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_ProcTypeAnonymous;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add(['var',
- ' ProcA: procedure;',
- ' MethodB: procedure of object;',
- ' ProcC: procedure; varargs;',
- ' ProcD: procedure(i: longint; const j: string; var c: char; out d: double);',
- ' ProcE: function: nativeint;',
- ' p: pointer;',
- 'begin',
- ' p:=typeinfo(proca);']);
- ConvertProgram;
- CheckSource('TestRTTI_ProcTypeAnonymous',
- LinesToStr([ // statements
- 'this.$rtti.$ProcVar("ProcA$a", {',
- ' procsig: rtl.newTIProcSig([])',
- '});',
- 'this.ProcA = null;',
- 'this.$rtti.$MethodVar("MethodB$a", {',
- ' procsig: rtl.newTIProcSig([]),',
- ' methodkind: 0',
- '});',
- 'this.MethodB = null;',
- 'this.$rtti.$ProcVar("ProcC$a", {',
- ' procsig: rtl.newTIProcSig([], null, 2)',
- '});',
- 'this.ProcC = null;',
- 'this.$rtti.$ProcVar("ProcD$a", {',
- ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
- '});',
- 'this.ProcD = null;',
- 'this.$rtti.$ProcVar("ProcE$a", {',
- ' procsig: rtl.newTIProcSig([], rtl.nativeint)',
- '});',
- 'this.ProcE = null;',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["ProcA$a"];',
- '']));
- 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, [], 4);',
- '});',
- 'rtl.createClass(this, "TEagle", this.TBird, function () {',
- ' this.Fly = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("Fly", 0, [], 4);',
- '});',
- '']),
- 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 = "\x00";',
- ' 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, 4);',
- ' $r.addField("VarC", rtl.char, 4);',
- ' $r.addField("VarS", rtl.string, 4);',
- ' $r.addField("VarD", rtl.double, 4);',
- ' $r.addField("VarB", rtl.boolean, 4);',
- ' $r.addField("VarLW", rtl.longword, 4);',
- ' $r.addField("VarSmI", rtl.smallint, 4);',
- ' $r.addField("VarW", rtl.word, 4);',
- ' $r.addField("VarShI", rtl.shortint, 4);',
- ' $r.addField("VarBy", rtl.byte, 4);',
- ' $r.addField("VarExt", rtl.longint, 4);',
- ' $mod.$rtti.$DynArray("TObject.ArrB$a", {',
- ' eltype: rtl.byte',
- ' });',
- ' $r.addField("ArrA", $mod.$rtti["TObject.ArrB$a"], 4);',
- ' $r.addField("ArrB", $mod.$rtti["TObject.ArrB$a"], 4);',
- '});',
- '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_FieldPrivate;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add('{$RTTI explicit fields([vcPrivate,vcProtected,vcPublic,vcPublished])}');
- Add(' TObject = class');
- Add(' strict private');
- Add(' A1: word;');
- Add(' private');
- Add(' A2: word;');
- Add(' strict protected');
- Add(' B1: word;');
- Add(' protected');
- Add(' B2, B3: word;');
- Add(' public');
- Add(' C: word;');
- Add(' published');
- Add(' D: word;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_FieldPrivate',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.A1 = 0;',
- ' this.A2 = 0;',
- ' this.B1 = 0;',
- ' this.B2 = 0;',
- ' this.B3 = 0;',
- ' this.C = 0;',
- ' this.D = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addField("A1", rtl.word, 5);',
- ' $r.addField("A2", rtl.word, 0);',
- ' $r.addField("B1", rtl.word, 6);',
- ' $r.addField("B2", rtl.word, 1);',
- ' $r.addField("B3", rtl.word, 1);',
- ' $r.addField("C", rtl.word);',
- ' $r.addField("D", rtl.word, 3);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_Method;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' private',
- ' procedure Internal; external name ''$intern'';',
- ' published',
- ' procedure Click; virtual; abstract;',
- ' procedure Notify(Sender: TObject); virtual; abstract;',
- ' function GetNotify: boolean; external name ''GetNotify'';',
- ' procedure Println(a,b: longint); varargs; virtual; abstract;',
- ' function Fetch(URL: string): word; async; external name ''Fetch'';',
- ' end;',
- '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, [], 4);',
- ' $r.addMethod("Notify", 0, [["Sender", $r]], 4);',
- ' $r.addMethod("GetNotify", 1, [], 4, rtl.boolean, 4);',
- ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], 4, null, 2);',
- ' $r.addMethod("Fetch", 1, [["URL", rtl.string]], 4, rtl.word, 20);',
- '});',
- '']),
- 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]], 4);',
- '$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]], 4);',
- '$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]], 4);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_MethodPrivate;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add('{$RTTI explicit methods([vcPrivate,vcProtected,vcPublic,vcPublished])}');
- Add(' TObject = class');
- Add(' private');
- Add(' procedure PrivateProc(a: word); virtual; abstract;');
- Add(' protected');
- Add(' class function ProtectedFunc: word; virtual; abstract;');
- Add(' public');
- Add(' class procedure PublicProc; virtual; abstract;');
- Add(' constructor Create;');
- Add(' destructor Destroy;');
- Add(' published');
- Add(' function PublishedProc: word; virtual; abstract;');
- Add(' end;');
- Add('constructor TObject.Create;');
- Add('begin');
- Add('end;');
- Add('destructor TObject.Destroy;');
- Add('begin');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_MethodPrivate',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- ' this.Destroy = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("PrivateProc", 0, [["a", rtl.word]], 0);',
- ' $r.addMethod("ProtectedFunc", 5, [], 1, rtl.word);',
- ' $r.addMethod("PublicProc", 4, []);',
- ' $r.addMethod("Create", 2, []);',
- ' $r.addMethod("Destroy", 3, []);',
- ' $r.addMethod("PublishedProc", 1, [], 4, rtl.word);',
- '});',
- '']),
- 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",',
- ' 4,',
- ' {',
- ' stored: "FColorStored"',
- ' }',
- ' );',
- ' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
- ' $r.addProperty(',
- ' "ExtSizeB",',
- ' 11,',
- ' rtl.longint,',
- ' "$getSize",',
- ' "$setSize",',
- ' 4,',
- ' {',
- ' stored: "$extSizeStored"',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "ExtSizeC",',
- ' 12,',
- ' rtl.longint,',
- ' "$extSize",',
- ' "$extSize",',
- ' 4,',
- ' {',
- ' 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_PropertyPrivate;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add('{$RTTI explicit properties([vcPrivate,vcProtected,vcPublic,vcPublished])}');
- Add(' TObject = class');
- Add(' private');
- Add(' FWord: word;');
- Add(' function GetWord: word; virtual; abstract;');
- Add(' procedure SetWord(Value: word); virtual; abstract;');
- Add(' property PrivateWord: word read FWord write FWord;');
- Add(' protected');
- Add(' property ProtectedWord: word read FWord write SetWord;');
- Add(' public');
- Add(' property PublicWord: word read GetWord;');
- Add(' published');
- Add(' property PublishedWord: word read FWord;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_PropertyPrivate',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FWord = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "PrivateWord",',
- ' 0,',
- ' rtl.word,',
- ' "FWord",',
- ' "FWord",',
- ' 0',
- ' );',
- ' $r.addProperty(',
- ' "ProtectedWord",',
- ' 2,',
- ' rtl.word,',
- ' "FWord",',
- ' "SetWord",',
- ' 1',
- ' );',
- ' $r.addProperty("PublicWord", 1, rtl.word, "GetWord", "", 2);',
- ' $r.addProperty(',
- ' "PublishedWord",',
- ' 0,',
- ' rtl.word,',
- ' "FWord",',
- ' ""',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_ClassProperty;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add('type');
- Add('{$RTTI explicit properties([vcPrivate,vcProtected,vcPublic,vcPublished])}');
- Add(' TObject = class');
- Add(' private');
- Add(' class var FWord: word;');
- Add(' class function GetWord: word; virtual; abstract;');
- Add(' class procedure SetWord(Value: word); virtual; abstract;');
- Add(' class property PrivateWord: word read FWord write FWord;');
- Add(' protected');
- Add(' class property ProtectedWord: word read FWord write SetWord;');
- Add(' public');
- Add(' class property PublicWord: word read GetWord;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_ClassProperty',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.FWord = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "PrivateWord",',
- ' 32,',
- ' rtl.word,',
- ' "FWord",',
- ' "FWord",',
- ' 0',
- ' );',
- ' $r.addProperty(',
- ' "ProtectedWord",',
- ' 34,',
- ' rtl.word,',
- ' "FWord",',
- ' "SetWord",',
- ' 1',
- ' );',
- ' $r.addProperty(',
- ' "PublicWord",',
- ' 33,',
- ' rtl.word,',
- ' "GetWord",',
- ' "",',
- ' 2',
- ' );',
- '});',
- '']),
- 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+}',
- ' 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"], 4);',
- '});',
- '']),
- 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",',
- ' 4,',
- ' {',
- ' index: 1',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B2",',
- ' 17,',
- ' rtl.boolean,',
- ' "GetEnumBool",',
- ' "FB",',
- ' 4,',
- ' {',
- ' index: $mod.TEnum.blue',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I1",',
- ' 19,',
- ' rtl.boolean,',
- ' "GetStrIntBool",',
- ' "SetStrIntBool",',
- ' 4,',
- ' {',
- ' 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",',
- ' "",',
- ' 4,',
- ' {',
- ' stored: "FB"',
- ' }',
- ' );',
- ' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
- ' $r.addProperty(',
- ' "BoolE",',
- ' 12,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' 4,',
- ' {',
- ' 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",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B2",',
- ' 0,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B3",',
- ' 0,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I1",',
- ' 0,',
- ' rtl.longint,',
- ' "FI",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: 2',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I2",',
- ' 0,',
- ' rtl.longint,',
- ' "FI",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: 3',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "E1",',
- ' 0,',
- ' $mod.$rtti["TEnum"],',
- ' "FE",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: $mod.TEnum.red',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "E2",',
- ' 0,',
- ' $mod.$rtti["TEnum"],',
- ' "FE",',
- ' "",',
- ' 4,',
- ' {',
- ' 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",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: {}',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set2",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: rtl.createSet($mod.TEnum.red)',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set3",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' 4,',
- ' {',
- ' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set4",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' 4,',
- ' {',
- ' 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",',
- ' "",',
- ' 4,',
- ' {',
- ' 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",',
- ' "",',
- ' 4,',
- ' {',
- ' 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, [], 4);',
- '});',
- '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, [], 4);',
- '});',
- 'rtl.createClass(this, "TSky", this.TObject, function () {',
- ' this.DoIt = function () {',
- ' $mod.TObject.DoIt.call(this);',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("DoIt", 0, [], 4);',
- '});',
- '']),
- 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([], 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"], 4);',
- ' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]], 4);',
- ' $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([], 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"], 4);',
- '});',
- '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([])',
- '});',
- 'this.$rtti.$MethodVar("TMethod", {',
- ' procsig: rtl.newTIProcSig([]),',
- ' 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, [], rtl.longint);',
- ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
- ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem", 2);',
- ' }',
- ');',
- '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, [], rtl.longint);',
- ' $r.addMethod("_Release", 1, [], rtl.longint);',
- ' }',
- ');',
- 'rtl.createInterface(',
- ' this,',
- ' "IBird",',
- ' "{9CC77572-0E45-3594-9A88-9E8D865C9E0A}",',
- ' ["GetItem", "SetItem"],',
- ' this.IUnknown,',
- ' function () {',
- ' var $r = this.$rtti;',
- ' $r.addMethod("GetItem", 1, [], rtl.longint);',
- ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
- ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem", 2);',
- ' }',
- ');',
- '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, [], 4, 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, [], pas.unit2.$rtti["TWordArray"]);',
- ' $r.addMethod("Glide", 1, [], 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 = "\x00";',
- '$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;',
- ' [Tcustom(15)]',
- ' Width, Height: 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, 4, {',
- ' attr: [$mod.TCustomAttribute, "Create"]',
- ' });',
- ' $r.addProperty(',
- ' "Size",',
- ' 0,',
- ' rtl.word,',
- ' "FField",',
- ' "",',
- ' 4,',
- ' {',
- ' attr: [$mod.TCustomAttribute, "Create$1", [14]]',
- ' }',
- ' );',
- ' $r.addMethod(',
- ' "Fly",',
- ' 0,',
- ' [],',
- ' 4,',
- ' null,',
- ' 0,',
- ' {',
- ' attr: [$mod.TCustomAttribute, "Create$1", [15]]',
- ' });',
- '});',
- 'rtl.recNewT(this, "TRec", function () {',
- ' this.Size = 0;',
- ' this.Width = 0;',
- ' this.Height = 0;',
- ' this.$eq = function (b) {',
- ' return (this.Size === b.Size) && (this.Width === b.Width) && (this.Height === b.Height);',
- ' };',
- ' this.$assign = function (s) {',
- ' this.Size = s.Size;',
- ' this.Width = s.Width;',
- ' this.Height = s.Height;',
- ' return this;',
- ' };',
- ' var $r = $mod.$rtti.$Record("TRec", {});',
- ' $r.addField("Size", rtl.word, 2, {',
- ' attr: [',
- ' $mod.TCustomAttribute,',
- ' "Create",',
- ' $mod.TCustomAttribute,',
- ' "Create$1",',
- ' [14]',
- ' ]',
- ' });',
- ' $r.addField("Width", rtl.word, 2, {',
- ' attr: [$mod.TCustomAttribute, "Create$1", [15]]',
- ' });',
- ' $r.addField("Height", rtl.word);',
- '});',
- '']),
- 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.TestAttributes_InterfacesList;
- begin
- WithTypeInfo:=true;
- StartProgram(false);
- Add([
- '{$mode Delphi}',
- 'type',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- ' IInterface = interface end;',
- ' TCustomAttribute = class',
- ' end;',
- ' Red = class(TCustomAttribute);',
- ' Blue = class(TCustomAttribute);',
- ' [Red]',
- ' IBird<T> = interface',
- ' procedure Fly;',
- ' end;',
- ' [Blue]',
- ' IEagle = interface(IBird<Word>)',
- ' procedure Dive;',
- ' end;',
- ' TAnt = class(TObject, IEagle)',
- ' procedure Fly; virtual; abstract;',
- ' procedure Dive; virtual; abstract;',
- ' end;',
- 'constructor TObject.Create;',
- 'begin',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestAttributes_InterfacesList',
- LinesToStr([ // statements
- '$mod.$rtti.$Interface("IBird<System.Word>");',
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' return this;',
- ' };',
- '});',
- 'rtl.createInterface(',
- ' this,',
- ' "IInterface",',
- ' "{B92D5841-698D-3153-90C5-000000000000}",',
- ' [],',
- ' null,',
- ' function () {',
- ' this.$kind = "com";',
- ' }',
- ');',
- 'rtl.createClass(this, "TCustomAttribute", this.TObject, function () {',
- '});',
- 'rtl.createClass(this, "Red", this.TCustomAttribute, function () {',
- '});',
- 'rtl.createClass(this, "Blue", this.TCustomAttribute, function () {',
- '});',
- 'rtl.createInterface(',
- ' this,',
- ' "IBird$G1",',
- ' "{14691591-6648-3574-B8C8-FAAD81DAC421}",',
- ' ["Fly"],',
- ' this.IInterface,',
- ' function () {',
- ' var $r = this.$rtti;',
- ' $r.addMethod("Fly", 0, []);',
- ' $r.attr = [$mod.Red, "Create"];',
- ' },',
- ' "IBird<System.Word>"',
- ');',
- 'rtl.createInterface(',
- ' this,',
- ' "IEagle",',
- ' "{5F4202AE-F2BE-37FD-8A88-1A2F926F1117}",',
- ' ["Dive"],',
- ' this.IBird$G1,',
- ' function () {',
- ' var $r = this.$rtti;',
- ' $r.addMethod("Dive", 0, []);',
- ' $r.attr = [$mod.Blue, "Create"];',
- ' }',
- ');',
- 'rtl.createClass(this, "TAnt", this.TObject, function () {',
- ' rtl.addIntf(this, $mod.IEagle);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- 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
- 'this.TArrByteChar$clone = function (a) {',
- ' var b = [];',
- ' b.length = 256;',
- ' for (var c = 0; c < 256; c++) b[c] = a[c].slice(0);',
- ' return b;',
- '};',
- '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 = "\x00";',
- ' 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 = "\x00";',
- ' 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.TestRangeChecks_AssignCurrency;
- begin
- Scanner.Options:=Scanner.Options+[po_CAssignments];
- StartProgram(false);
- Add([
- '{$R+}',
- 'var',
- ' c: currency = 2.34;',
- ' i: double;',
- 'procedure DoIt(p: currency);',
- 'begin',
- ' c:=i;',
- ' c+=i;',
- ' c:=1;',
- 'end;',
- '{$R-}',
- 'procedure DoSome;',
- 'begin',
- ' DoIt(i);',
- ' c:=i;',
- ' c:=2;',
- 'end;',
- 'begin',
- '{$R+}',
- '']);
- ConvertProgram;
- CheckSource('TestRangeChecks_AssignCurrency',
- LinesToStr([ // statements
- 'this.c = 2.34;',
- 'this.i = 0.0;',
- 'this.DoIt = function (p) {',
- ' rtl.rc(p, -922337203685477, 922337203685477);',
- ' $mod.c = rtl.rc(rtl.trunc($mod.i * 10000), -922337203685477, 922337203685477);',
- ' rtl.rc($mod.c += rtl.trunc($mod.i * 10000), -922337203685477, 922337203685477);',
- ' $mod.c = 10000;',
- '};',
- 'this.DoSome = function () {',
- ' $mod.DoIt($mod.i * 10000);',
- ' $mod.c = rtl.trunc($mod.i * 10000);',
- ' $mod.c = 20000;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- 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 for 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 for 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 or promise 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_AnonymousProc_PromiseViaDotContext;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' TObject = class',
- ' public',
- ' procedure Fly(Prom: TJSPromise);',
- ' end;',
- ' TFunc = reference to procedure(Bird: TObject);',
- 'procedure TObject.Fly(Prom: TJSPromise);',
- 'begin',
- 'end;',
- 'function Crawl: jsvalue; async;',
- 'begin',
- 'end;',
- 'procedure Add(Func: TFunc);',
- 'begin',
- 'end;',
- 'begin',
- ' Add(procedure(Bird: TObject)',
- ' begin',
- ' Bird.Fly(Crawl());',
- ' end);',
- '']);
- ConvertProgram;
- CheckSource('TestAsync_AnonymousProc_PromiseViaDotContext',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Fly = function (Prom) {',
- ' };',
- '});',
- 'this.Crawl = async function () {',
- ' var Result = undefined;',
- ' return Result;',
- '};',
- 'this.Add = function (Func) {',
- '};',
- '']),
- LinesToStr([
- '$mod.Add(function (Bird) {',
- ' Bird.Fly($mod.Crawl());',
- '});',
- '']));
- 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;
- procedure TTestModule.TestAWait_ClassAs;
- begin
- StartProgram(false);
- Add([
- '{$mode objfpc}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' TObject = class',
- ' function Run: TObject; async;',
- ' end;',
- ' TBird = class',
- ' function Fly: TBird; async;',
- ' end;',
- 'function TObject.Run: TObject; async;',
- 'begin',
- 'end;',
- 'function TBird.Fly: TBird;', // async modifier not needed in impl
- 'var o: TObject;',
- 'begin',
- ' o:=await(TObject,Run);',
- ' o:=await(TObject,Fly);',
- ' o:=await(TBird,Fly);',
- ' o:=await(TObject,inherited Run);',
- ' o:=await(TObject,inherited Run) as TBird;',
- 'end;',
- 'begin',
- ' ']);
- ConvertProgram;
- CheckSource('TestAWait_ClassAs',
- LinesToStr([ // statements
- 'rtl.createClass(this, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Run = async function () {',
- ' var Result = null;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass(this, "TBird", this.TObject, function () {',
- ' this.Fly = async function () {',
- ' var Result = null;',
- ' var o = null;',
- ' o = await this.Run();',
- ' o = await this.Fly();',
- ' o = await this.Fly();',
- ' o = await $mod.TObject.Run.call(this);',
- ' o = rtl.as(await $mod.TObject.Run.call(this), $mod.TBird);',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([
- '']));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestLibrary_Empty;
- begin
- StartLibrary(false);
- Add([
- '']);
- ConvertLibrary;
- CheckFullSource('TestLibrary_Empty',
- LinesToStr([ // statements
- 'rtl.module("library", [], function () {',
- ' var $mod = this;',
- ' $mod.$main = function () {',
- ' };',
- '});',
- 'rtl.run("library");',
- '']));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestLibrary_ExportFunc;
- begin
- StartLibrary(false);
- Add([
- 'procedure Run(w: word);',
- 'begin',
- 'end;',
- 'exports',
- ' Run;',
- ' run name ''Foo'';',
- ' test1.run name ''Test1Run'';',
- '']);
- ConvertLibrary;
- CheckFullSource('TestLibrary_ExportFunc',
- LinesToStr([ // statements
- 'rtl.module("library", [], function () {',
- ' var $mod = this;',
- ' this.Run = function (w) {',
- ' };',
- ' $mod.$main = function () {',
- ' };',
- '});',
- 'rtl.run("library");',
- 'export const Run = pas.library.Run;',
- 'export const Foo = pas.library.Run;',
- 'export const Test1Run = pas.library.Run;',
- '']));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestLibrary_ExportFuncOverloadedFail;
- begin
- StartLibrary(false);
- Add([
- 'procedure Run(w: word); overload;',
- 'begin',
- 'end;',
- 'procedure Run(s: string); overload;',
- 'begin',
- 'end;',
- 'exports',
- ' Run;',
- '']);
- SetExpectedPasResolverError(sCantDetermineWhichOverloadedFunctionToCall,
- nCantDetermineWhichOverloadedFunctionToCall);
- ConvertLibrary;
- end;
- procedure TTestModule.TestLibrary_Export_Index_Fail;
- begin
- StartLibrary(false);
- Add([
- 'procedure Run(w: word);',
- 'begin',
- 'end;',
- 'exports',
- ' Run index 3;',
- '']);
- SetExpectedPasResolverError('Not supported: export index',nNotSupportedX);
- ConvertLibrary;
- end;
- procedure TTestModule.TestLibrary_ExportVar;
- begin
- StartLibrary(false);
- Add([
- 'var Wing: word;',
- 'exports',
- ' Wing, wing name ''BirdArm'';',
- '']);
- ConvertLibrary;
- CheckFullSource('TestLibrary_ExportVar',
- LinesToStr([ // statements
- 'rtl.module("library", [], function () {',
- ' var $mod = this;',
- ' this.Wing = 0;',
- ' $mod.$main = function () {',
- ' };',
- '});',
- 'rtl.run("library");',
- 'export const vars = {};',
- 'Object.defineProperties(vars, {',
- ' Wing: {',
- ' enumerable: true,',
- ' get: function () {',
- ' return pas.library.Wing;',
- ' },',
- ' set: function (v) {',
- ' pas.library.Wing = v;',
- ' }',
- ' },',
- ' BirdArm: {',
- ' enumerable: true,',
- ' get: function () {',
- ' return pas.library.Wing;',
- ' },',
- ' set: function (v) {',
- ' pas.library.Wing = v;',
- ' }',
- ' }',
- '});',
- '']));
- CheckResolverUnexpectedHints();
- end;
- procedure TTestModule.TestLibrary_ExportUnitFunc;
- begin
- AddModuleWithIntfImplSrc('Unit1.pas',
- LinesToStr([
- 'type',
- ' TAnt = class',
- ' class function Crawl: word; static;',
- ' end;',
- 'function Fly: word;',
- '']),
- LinesToStr([
- 'function Fly: word;',
- 'begin',
- 'end;',
- 'class function TAnt.Crawl: word;',
- 'begin',
- 'end;',
- '']));
- StartLibrary(true,[supTObject]);
- Add([
- 'uses unit1;',
- 'exports',
- ' Fly;',
- ' TAnt.Crawl;',
- '']);
- ConvertLibrary;
- CheckFullSource('TestLibrary_ExportUnitFunc',
- LinesToStr([ // statements
- 'rtl.module("library", ["system", "Unit1"], function () {',
- ' var $mod = this;',
- ' $mod.$main = function () {',
- ' };',
- '});',
- 'rtl.run("library");',
- 'export const Fly = pas.Unit1.Fly;',
- 'export const Crawl = pas.Unit1.TAnt.Crawl;',
- '']));
- CheckResolverUnexpectedHints();
- end;
- Initialization
- RegisterTests([TTestModule]);
- end.
|
