| 12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734147351473614737147381473914740147411474214743147441474514746147471474814749147501475114752147531475414755147561475714758147591476014761147621476314764147651476614767147681476914770147711477214773147741477514776147771477814779147801478114782147831478414785147861478714788147891479014791147921479314794147951479614797147981479914800148011480214803148041480514806148071480814809148101481114812148131481414815148161481714818148191482014821148221482314824148251482614827148281482914830148311483214833148341483514836148371483814839148401484114842148431484414845148461484714848148491485014851148521485314854148551485614857148581485914860148611486214863148641486514866148671486814869148701487114872148731487414875148761487714878148791488014881148821488314884148851488614887148881488914890148911489214893148941489514896148971489814899149001490114902149031490414905149061490714908149091491014911149121491314914149151491614917149181491914920149211492214923149241492514926149271492814929149301493114932149331493414935149361493714938149391494014941149421494314944149451494614947149481494914950149511495214953149541495514956149571495814959149601496114962149631496414965149661496714968149691497014971149721497314974149751497614977149781497914980149811498214983149841498514986149871498814989149901499114992149931499414995149961499714998149991500015001150021500315004150051500615007150081500915010150111501215013150141501515016150171501815019150201502115022150231502415025150261502715028150291503015031150321503315034150351503615037150381503915040150411504215043150441504515046150471504815049150501505115052150531505415055150561505715058150591506015061150621506315064150651506615067150681506915070150711507215073150741507515076150771507815079150801508115082150831508415085150861508715088150891509015091150921509315094150951509615097150981509915100151011510215103151041510515106151071510815109151101511115112151131511415115151161511715118151191512015121151221512315124151251512615127151281512915130151311513215133151341513515136151371513815139151401514115142151431514415145151461514715148151491515015151151521515315154151551515615157151581515915160151611516215163151641516515166151671516815169151701517115172151731517415175151761517715178151791518015181151821518315184151851518615187151881518915190151911519215193151941519515196151971519815199152001520115202152031520415205152061520715208152091521015211152121521315214152151521615217152181521915220152211522215223152241522515226152271522815229152301523115232152331523415235152361523715238152391524015241152421524315244152451524615247152481524915250152511525215253152541525515256152571525815259152601526115262152631526415265152661526715268152691527015271152721527315274152751527615277152781527915280152811528215283152841528515286152871528815289152901529115292152931529415295152961529715298152991530015301153021530315304153051530615307153081530915310153111531215313153141531515316153171531815319153201532115322153231532415325153261532715328153291533015331153321533315334153351533615337153381533915340153411534215343153441534515346153471534815349153501535115352153531535415355153561535715358153591536015361153621536315364153651536615367153681536915370153711537215373153741537515376153771537815379153801538115382153831538415385153861538715388153891539015391153921539315394153951539615397153981539915400154011540215403154041540515406154071540815409154101541115412154131541415415154161541715418154191542015421154221542315424154251542615427154281542915430154311543215433154341543515436154371543815439154401544115442154431544415445154461544715448154491545015451154521545315454154551545615457154581545915460154611546215463154641546515466154671546815469154701547115472154731547415475154761547715478154791548015481154821548315484154851548615487154881548915490154911549215493154941549515496154971549815499155001550115502155031550415505155061550715508155091551015511155121551315514155151551615517155181551915520155211552215523155241552515526155271552815529155301553115532155331553415535155361553715538155391554015541155421554315544155451554615547155481554915550155511555215553155541555515556155571555815559155601556115562155631556415565155661556715568155691557015571155721557315574155751557615577155781557915580155811558215583155841558515586155871558815589155901559115592155931559415595155961559715598155991560015601156021560315604156051560615607156081560915610156111561215613156141561515616156171561815619156201562115622156231562415625156261562715628156291563015631156321563315634156351563615637156381563915640156411564215643156441564515646156471564815649156501565115652156531565415655156561565715658156591566015661156621566315664156651566615667156681566915670156711567215673156741567515676156771567815679156801568115682156831568415685156861568715688156891569015691156921569315694156951569615697156981569915700157011570215703157041570515706157071570815709157101571115712157131571415715157161571715718157191572015721157221572315724157251572615727157281572915730157311573215733157341573515736157371573815739157401574115742157431574415745157461574715748157491575015751157521575315754157551575615757157581575915760157611576215763157641576515766157671576815769157701577115772157731577415775157761577715778157791578015781157821578315784157851578615787157881578915790157911579215793157941579515796157971579815799158001580115802158031580415805158061580715808158091581015811158121581315814158151581615817158181581915820158211582215823158241582515826158271582815829158301583115832158331583415835158361583715838158391584015841158421584315844158451584615847158481584915850158511585215853158541585515856158571585815859158601586115862158631586415865158661586715868158691587015871158721587315874158751587615877158781587915880158811588215883158841588515886158871588815889158901589115892158931589415895158961589715898158991590015901159021590315904159051590615907159081590915910159111591215913159141591515916159171591815919159201592115922159231592415925159261592715928159291593015931159321593315934159351593615937159381593915940159411594215943159441594515946159471594815949159501595115952159531595415955159561595715958159591596015961159621596315964159651596615967159681596915970159711597215973159741597515976159771597815979159801598115982159831598415985159861598715988159891599015991159921599315994159951599615997159981599916000160011600216003160041600516006160071600816009160101601116012160131601416015160161601716018160191602016021160221602316024160251602616027160281602916030160311603216033160341603516036160371603816039160401604116042160431604416045160461604716048160491605016051160521605316054160551605616057160581605916060160611606216063160641606516066160671606816069160701607116072160731607416075160761607716078160791608016081160821608316084160851608616087160881608916090160911609216093160941609516096160971609816099161001610116102161031610416105161061610716108161091611016111161121611316114161151611616117161181611916120161211612216123161241612516126161271612816129161301613116132161331613416135161361613716138161391614016141161421614316144161451614616147161481614916150161511615216153161541615516156161571615816159161601616116162161631616416165161661616716168161691617016171161721617316174161751617616177161781617916180161811618216183161841618516186161871618816189161901619116192161931619416195161961619716198161991620016201162021620316204162051620616207162081620916210162111621216213162141621516216162171621816219162201622116222162231622416225162261622716228162291623016231162321623316234162351623616237162381623916240162411624216243162441624516246162471624816249162501625116252162531625416255162561625716258162591626016261162621626316264162651626616267162681626916270162711627216273162741627516276162771627816279162801628116282162831628416285162861628716288162891629016291162921629316294162951629616297162981629916300163011630216303163041630516306163071630816309163101631116312163131631416315163161631716318163191632016321163221632316324163251632616327163281632916330163311633216333163341633516336163371633816339163401634116342163431634416345163461634716348163491635016351163521635316354163551635616357163581635916360163611636216363163641636516366163671636816369163701637116372163731637416375163761637716378163791638016381163821638316384163851638616387163881638916390163911639216393163941639516396163971639816399164001640116402164031640416405164061640716408164091641016411164121641316414164151641616417164181641916420164211642216423164241642516426164271642816429164301643116432164331643416435164361643716438164391644016441164421644316444164451644616447164481644916450164511645216453164541645516456164571645816459164601646116462164631646416465164661646716468164691647016471164721647316474164751647616477164781647916480164811648216483164841648516486164871648816489164901649116492164931649416495164961649716498164991650016501165021650316504165051650616507165081650916510165111651216513165141651516516165171651816519165201652116522165231652416525165261652716528165291653016531165321653316534165351653616537165381653916540165411654216543165441654516546165471654816549165501655116552165531655416555165561655716558165591656016561165621656316564165651656616567165681656916570165711657216573165741657516576165771657816579165801658116582165831658416585165861658716588165891659016591165921659316594165951659616597165981659916600166011660216603166041660516606166071660816609166101661116612166131661416615166161661716618166191662016621166221662316624166251662616627166281662916630166311663216633166341663516636166371663816639166401664116642166431664416645166461664716648166491665016651166521665316654166551665616657166581665916660166611666216663166641666516666166671666816669166701667116672166731667416675166761667716678166791668016681166821668316684166851668616687166881668916690166911669216693166941669516696166971669816699167001670116702167031670416705167061670716708167091671016711167121671316714167151671616717167181671916720167211672216723167241672516726167271672816729167301673116732167331673416735167361673716738167391674016741167421674316744167451674616747167481674916750167511675216753167541675516756167571675816759167601676116762167631676416765167661676716768167691677016771167721677316774167751677616777167781677916780167811678216783167841678516786167871678816789167901679116792167931679416795167961679716798167991680016801168021680316804168051680616807168081680916810168111681216813168141681516816168171681816819168201682116822168231682416825168261682716828168291683016831168321683316834168351683616837168381683916840168411684216843168441684516846168471684816849168501685116852168531685416855168561685716858168591686016861168621686316864168651686616867168681686916870168711687216873168741687516876168771687816879168801688116882168831688416885168861688716888168891689016891168921689316894168951689616897168981689916900169011690216903169041690516906169071690816909169101691116912169131691416915169161691716918169191692016921169221692316924169251692616927169281692916930169311693216933169341693516936169371693816939169401694116942169431694416945169461694716948169491695016951169521695316954169551695616957169581695916960169611696216963169641696516966169671696816969169701697116972169731697416975169761697716978169791698016981169821698316984169851698616987169881698916990169911699216993169941699516996169971699816999170001700117002170031700417005170061700717008170091701017011170121701317014170151701617017170181701917020170211702217023170241702517026170271702817029170301703117032170331703417035170361703717038170391704017041170421704317044170451704617047170481704917050170511705217053170541705517056170571705817059170601706117062170631706417065170661706717068170691707017071170721707317074170751707617077170781707917080170811708217083170841708517086170871708817089170901709117092170931709417095170961709717098170991710017101171021710317104171051710617107171081710917110171111711217113171141711517116171171711817119171201712117122171231712417125171261712717128171291713017131171321713317134171351713617137171381713917140171411714217143171441714517146171471714817149171501715117152171531715417155171561715717158171591716017161171621716317164171651716617167171681716917170171711717217173171741717517176171771717817179171801718117182171831718417185171861718717188171891719017191171921719317194171951719617197171981719917200172011720217203172041720517206172071720817209172101721117212172131721417215172161721717218172191722017221172221722317224172251722617227172281722917230172311723217233172341723517236172371723817239172401724117242172431724417245172461724717248172491725017251172521725317254172551725617257172581725917260172611726217263172641726517266172671726817269172701727117272172731727417275172761727717278172791728017281172821728317284172851728617287172881728917290172911729217293172941729517296172971729817299173001730117302173031730417305173061730717308173091731017311173121731317314173151731617317173181731917320173211732217323173241732517326173271732817329173301733117332173331733417335173361733717338173391734017341173421734317344173451734617347173481734917350173511735217353173541735517356173571735817359173601736117362173631736417365173661736717368173691737017371173721737317374173751737617377173781737917380173811738217383173841738517386173871738817389173901739117392173931739417395173961739717398173991740017401174021740317404174051740617407174081740917410174111741217413174141741517416174171741817419174201742117422174231742417425174261742717428174291743017431174321743317434174351743617437174381743917440174411744217443174441744517446174471744817449174501745117452174531745417455174561745717458174591746017461174621746317464174651746617467174681746917470174711747217473174741747517476174771747817479174801748117482174831748417485174861748717488174891749017491174921749317494174951749617497174981749917500175011750217503175041750517506175071750817509175101751117512175131751417515175161751717518175191752017521175221752317524175251752617527175281752917530175311753217533175341753517536175371753817539175401754117542175431754417545175461754717548175491755017551175521755317554175551755617557175581755917560175611756217563175641756517566175671756817569175701757117572175731757417575175761757717578175791758017581175821758317584175851758617587175881758917590175911759217593175941759517596175971759817599176001760117602176031760417605176061760717608176091761017611176121761317614176151761617617176181761917620176211762217623176241762517626176271762817629176301763117632176331763417635176361763717638176391764017641176421764317644176451764617647176481764917650176511765217653176541765517656176571765817659176601766117662176631766417665176661766717668176691767017671176721767317674176751767617677176781767917680176811768217683176841768517686176871768817689176901769117692176931769417695176961769717698176991770017701177021770317704177051770617707177081770917710177111771217713177141771517716177171771817719177201772117722177231772417725177261772717728177291773017731177321773317734177351773617737177381773917740177411774217743177441774517746177471774817749177501775117752177531775417755177561775717758177591776017761177621776317764177651776617767177681776917770177711777217773177741777517776177771777817779177801778117782177831778417785177861778717788177891779017791177921779317794177951779617797177981779917800178011780217803178041780517806178071780817809178101781117812178131781417815178161781717818178191782017821178221782317824178251782617827178281782917830178311783217833178341783517836178371783817839178401784117842178431784417845178461784717848178491785017851178521785317854178551785617857178581785917860178611786217863178641786517866178671786817869178701787117872178731787417875178761787717878178791788017881178821788317884178851788617887178881788917890178911789217893178941789517896178971789817899179001790117902179031790417905179061790717908179091791017911179121791317914179151791617917179181791917920179211792217923179241792517926179271792817929179301793117932179331793417935179361793717938179391794017941179421794317944179451794617947179481794917950179511795217953179541795517956179571795817959179601796117962179631796417965179661796717968179691797017971179721797317974179751797617977179781797917980179811798217983179841798517986179871798817989179901799117992179931799417995179961799717998179991800018001180021800318004180051800618007180081800918010180111801218013180141801518016180171801818019180201802118022180231802418025180261802718028180291803018031180321803318034180351803618037180381803918040180411804218043180441804518046180471804818049180501805118052180531805418055180561805718058180591806018061180621806318064180651806618067180681806918070180711807218073180741807518076180771807818079180801808118082180831808418085180861808718088180891809018091180921809318094180951809618097180981809918100181011810218103181041810518106181071810818109181101811118112181131811418115181161811718118181191812018121181221812318124181251812618127181281812918130181311813218133181341813518136181371813818139181401814118142181431814418145181461814718148181491815018151181521815318154181551815618157181581815918160181611816218163181641816518166181671816818169181701817118172181731817418175181761817718178181791818018181181821818318184181851818618187181881818918190181911819218193181941819518196181971819818199182001820118202182031820418205182061820718208182091821018211182121821318214182151821618217182181821918220182211822218223182241822518226182271822818229182301823118232182331823418235182361823718238182391824018241182421824318244182451824618247182481824918250182511825218253182541825518256182571825818259182601826118262182631826418265182661826718268182691827018271182721827318274182751827618277182781827918280182811828218283182841828518286182871828818289182901829118292182931829418295182961829718298182991830018301183021830318304183051830618307183081830918310183111831218313183141831518316183171831818319183201832118322183231832418325183261832718328183291833018331183321833318334183351833618337183381833918340183411834218343183441834518346183471834818349183501835118352183531835418355183561835718358183591836018361183621836318364183651836618367183681836918370183711837218373183741837518376183771837818379183801838118382183831838418385183861838718388183891839018391183921839318394183951839618397183981839918400184011840218403184041840518406184071840818409184101841118412184131841418415184161841718418184191842018421184221842318424184251842618427184281842918430184311843218433184341843518436184371843818439184401844118442184431844418445184461844718448184491845018451184521845318454184551845618457184581845918460184611846218463184641846518466184671846818469184701847118472184731847418475184761847718478184791848018481184821848318484184851848618487184881848918490184911849218493184941849518496184971849818499185001850118502185031850418505185061850718508185091851018511185121851318514185151851618517185181851918520185211852218523185241852518526185271852818529185301853118532185331853418535185361853718538185391854018541185421854318544185451854618547185481854918550185511855218553185541855518556185571855818559185601856118562185631856418565185661856718568185691857018571185721857318574185751857618577185781857918580185811858218583185841858518586185871858818589185901859118592185931859418595185961859718598185991860018601186021860318604186051860618607186081860918610186111861218613186141861518616186171861818619186201862118622186231862418625186261862718628186291863018631186321863318634186351863618637186381863918640186411864218643186441864518646186471864818649186501865118652186531865418655186561865718658186591866018661186621866318664186651866618667186681866918670186711867218673186741867518676186771867818679186801868118682186831868418685186861868718688186891869018691186921869318694186951869618697186981869918700187011870218703187041870518706187071870818709187101871118712187131871418715187161871718718187191872018721187221872318724187251872618727187281872918730187311873218733187341873518736187371873818739187401874118742187431874418745187461874718748187491875018751187521875318754187551875618757187581875918760187611876218763187641876518766187671876818769187701877118772187731877418775187761877718778187791878018781187821878318784187851878618787187881878918790187911879218793187941879518796187971879818799188001880118802188031880418805188061880718808188091881018811188121881318814188151881618817188181881918820188211882218823188241882518826188271882818829188301883118832188331883418835188361883718838188391884018841188421884318844188451884618847188481884918850188511885218853188541885518856188571885818859188601886118862188631886418865188661886718868188691887018871188721887318874188751887618877188781887918880188811888218883188841888518886188871888818889188901889118892188931889418895188961889718898188991890018901189021890318904189051890618907189081890918910189111891218913189141891518916189171891818919189201892118922189231892418925189261892718928189291893018931189321893318934189351893618937189381893918940189411894218943189441894518946189471894818949189501895118952189531895418955189561895718958189591896018961189621896318964189651896618967189681896918970189711897218973189741897518976189771897818979189801898118982189831898418985189861898718988189891899018991189921899318994189951899618997189981899919000190011900219003190041900519006190071900819009190101901119012190131901419015190161901719018190191902019021190221902319024190251902619027190281902919030190311903219033190341903519036190371903819039190401904119042190431904419045190461904719048190491905019051190521905319054190551905619057190581905919060190611906219063190641906519066190671906819069190701907119072190731907419075190761907719078190791908019081190821908319084190851908619087190881908919090190911909219093190941909519096190971909819099191001910119102191031910419105191061910719108191091911019111191121911319114191151911619117191181911919120191211912219123191241912519126191271912819129191301913119132191331913419135191361913719138191391914019141191421914319144191451914619147191481914919150191511915219153191541915519156191571915819159191601916119162191631916419165191661916719168191691917019171191721917319174191751917619177191781917919180191811918219183191841918519186191871918819189191901919119192191931919419195191961919719198191991920019201192021920319204192051920619207192081920919210192111921219213192141921519216192171921819219192201922119222192231922419225192261922719228192291923019231192321923319234192351923619237192381923919240192411924219243192441924519246192471924819249192501925119252192531925419255192561925719258192591926019261192621926319264192651926619267192681926919270192711927219273192741927519276192771927819279192801928119282192831928419285192861928719288192891929019291192921929319294192951929619297192981929919300193011930219303193041930519306193071930819309193101931119312193131931419315193161931719318193191932019321193221932319324193251932619327193281932919330193311933219333193341933519336193371933819339193401934119342193431934419345193461934719348193491935019351193521935319354193551935619357193581935919360193611936219363193641936519366193671936819369193701937119372193731937419375193761937719378193791938019381193821938319384193851938619387193881938919390193911939219393193941939519396193971939819399194001940119402194031940419405194061940719408194091941019411194121941319414194151941619417194181941919420194211942219423194241942519426194271942819429194301943119432194331943419435194361943719438194391944019441194421944319444194451944619447194481944919450194511945219453194541945519456194571945819459194601946119462194631946419465194661946719468194691947019471194721947319474194751947619477194781947919480194811948219483194841948519486194871948819489194901949119492194931949419495194961949719498194991950019501195021950319504195051950619507195081950919510195111951219513195141951519516195171951819519195201952119522195231952419525195261952719528195291953019531195321953319534195351953619537195381953919540195411954219543195441954519546195471954819549195501955119552195531955419555195561955719558195591956019561195621956319564195651956619567195681956919570195711957219573195741957519576195771957819579195801958119582195831958419585195861958719588195891959019591195921959319594195951959619597195981959919600196011960219603196041960519606196071960819609196101961119612196131961419615196161961719618196191962019621196221962319624196251962619627196281962919630196311963219633196341963519636196371963819639196401964119642196431964419645196461964719648196491965019651196521965319654196551965619657196581965919660196611966219663196641966519666196671966819669196701967119672196731967419675196761967719678196791968019681196821968319684196851968619687196881968919690196911969219693196941969519696196971969819699197001970119702197031970419705197061970719708197091971019711197121971319714197151971619717197181971919720197211972219723197241972519726197271972819729197301973119732197331973419735197361973719738197391974019741197421974319744197451974619747197481974919750197511975219753197541975519756197571975819759197601976119762197631976419765197661976719768197691977019771197721977319774197751977619777197781977919780197811978219783197841978519786197871978819789197901979119792197931979419795197961979719798197991980019801198021980319804198051980619807198081980919810198111981219813198141981519816198171981819819198201982119822198231982419825198261982719828198291983019831198321983319834198351983619837198381983919840198411984219843198441984519846198471984819849198501985119852198531985419855198561985719858198591986019861198621986319864198651986619867198681986919870198711987219873198741987519876198771987819879198801988119882198831988419885198861988719888198891989019891198921989319894198951989619897198981989919900199011990219903199041990519906199071990819909199101991119912199131991419915199161991719918199191992019921199221992319924199251992619927199281992919930199311993219933199341993519936199371993819939199401994119942199431994419945199461994719948199491995019951199521995319954199551995619957199581995919960199611996219963199641996519966199671996819969199701997119972199731997419975199761997719978199791998019981199821998319984199851998619987199881998919990199911999219993199941999519996199971999819999200002000120002200032000420005200062000720008200092001020011200122001320014200152001620017200182001920020200212002220023200242002520026200272002820029200302003120032200332003420035200362003720038200392004020041200422004320044200452004620047200482004920050200512005220053200542005520056200572005820059200602006120062200632006420065200662006720068200692007020071200722007320074200752007620077200782007920080200812008220083200842008520086200872008820089200902009120092200932009420095200962009720098200992010020101201022010320104201052010620107201082010920110201112011220113201142011520116201172011820119201202012120122201232012420125201262012720128201292013020131201322013320134201352013620137201382013920140201412014220143201442014520146201472014820149201502015120152201532015420155201562015720158201592016020161201622016320164201652016620167201682016920170201712017220173201742017520176201772017820179201802018120182201832018420185201862018720188201892019020191201922019320194201952019620197201982019920200202012020220203202042020520206202072020820209202102021120212202132021420215202162021720218202192022020221202222022320224202252022620227202282022920230202312023220233202342023520236202372023820239202402024120242202432024420245202462024720248202492025020251202522025320254202552025620257202582025920260202612026220263202642026520266202672026820269202702027120272202732027420275202762027720278202792028020281202822028320284202852028620287202882028920290202912029220293202942029520296202972029820299203002030120302203032030420305203062030720308203092031020311203122031320314203152031620317203182031920320203212032220323203242032520326203272032820329203302033120332203332033420335203362033720338203392034020341203422034320344203452034620347203482034920350203512035220353203542035520356203572035820359203602036120362203632036420365203662036720368203692037020371203722037320374203752037620377203782037920380203812038220383203842038520386203872038820389203902039120392203932039420395203962039720398203992040020401204022040320404204052040620407204082040920410204112041220413204142041520416204172041820419204202042120422204232042420425204262042720428204292043020431204322043320434204352043620437204382043920440204412044220443204442044520446204472044820449204502045120452204532045420455204562045720458204592046020461204622046320464204652046620467204682046920470204712047220473204742047520476204772047820479204802048120482204832048420485204862048720488204892049020491204922049320494204952049620497204982049920500205012050220503205042050520506205072050820509205102051120512205132051420515205162051720518205192052020521205222052320524205252052620527205282052920530205312053220533205342053520536205372053820539205402054120542205432054420545205462054720548205492055020551205522055320554205552055620557205582055920560205612056220563205642056520566205672056820569205702057120572205732057420575205762057720578205792058020581205822058320584205852058620587205882058920590205912059220593205942059520596205972059820599206002060120602206032060420605206062060720608206092061020611206122061320614206152061620617206182061920620206212062220623206242062520626206272062820629206302063120632206332063420635206362063720638206392064020641206422064320644206452064620647206482064920650206512065220653206542065520656206572065820659206602066120662206632066420665206662066720668206692067020671206722067320674206752067620677206782067920680206812068220683206842068520686206872068820689206902069120692206932069420695206962069720698206992070020701207022070320704207052070620707207082070920710207112071220713207142071520716207172071820719207202072120722207232072420725207262072720728207292073020731207322073320734207352073620737207382073920740207412074220743207442074520746207472074820749207502075120752207532075420755207562075720758207592076020761207622076320764207652076620767207682076920770207712077220773207742077520776207772077820779207802078120782207832078420785207862078720788207892079020791207922079320794207952079620797207982079920800208012080220803208042080520806208072080820809208102081120812208132081420815208162081720818208192082020821208222082320824208252082620827208282082920830208312083220833208342083520836208372083820839208402084120842208432084420845208462084720848208492085020851208522085320854208552085620857208582085920860208612086220863208642086520866208672086820869208702087120872208732087420875208762087720878208792088020881208822088320884208852088620887208882088920890208912089220893208942089520896208972089820899209002090120902209032090420905209062090720908209092091020911209122091320914209152091620917209182091920920209212092220923209242092520926209272092820929209302093120932209332093420935209362093720938209392094020941209422094320944209452094620947209482094920950209512095220953209542095520956209572095820959209602096120962209632096420965209662096720968209692097020971209722097320974209752097620977209782097920980209812098220983209842098520986209872098820989209902099120992209932099420995209962099720998209992100021001210022100321004210052100621007210082100921010210112101221013210142101521016210172101821019210202102121022210232102421025210262102721028210292103021031210322103321034210352103621037210382103921040210412104221043210442104521046210472104821049210502105121052210532105421055210562105721058210592106021061210622106321064210652106621067210682106921070210712107221073210742107521076210772107821079210802108121082210832108421085210862108721088210892109021091210922109321094210952109621097210982109921100211012110221103211042110521106211072110821109211102111121112211132111421115211162111721118211192112021121211222112321124211252112621127211282112921130211312113221133211342113521136211372113821139211402114121142211432114421145211462114721148211492115021151211522115321154211552115621157211582115921160211612116221163211642116521166211672116821169211702117121172211732117421175211762117721178211792118021181211822118321184211852118621187211882118921190211912119221193211942119521196211972119821199212002120121202212032120421205212062120721208212092121021211212122121321214212152121621217212182121921220212212122221223212242122521226212272122821229212302123121232212332123421235212362123721238212392124021241212422124321244212452124621247212482124921250212512125221253212542125521256212572125821259212602126121262212632126421265212662126721268212692127021271212722127321274212752127621277212782127921280212812128221283212842128521286212872128821289212902129121292212932129421295212962129721298212992130021301213022130321304213052130621307213082130921310213112131221313213142131521316213172131821319213202132121322213232132421325213262132721328213292133021331213322133321334213352133621337213382133921340213412134221343213442134521346213472134821349213502135121352213532135421355213562135721358213592136021361213622136321364213652136621367213682136921370213712137221373213742137521376213772137821379213802138121382213832138421385213862138721388213892139021391213922139321394213952139621397213982139921400214012140221403214042140521406214072140821409214102141121412214132141421415214162141721418214192142021421214222142321424214252142621427214282142921430214312143221433214342143521436214372143821439214402144121442214432144421445214462144721448214492145021451214522145321454214552145621457214582145921460214612146221463214642146521466214672146821469214702147121472214732147421475214762147721478214792148021481214822148321484214852148621487214882148921490214912149221493214942149521496214972149821499215002150121502215032150421505215062150721508215092151021511215122151321514215152151621517215182151921520215212152221523215242152521526215272152821529215302153121532215332153421535215362153721538215392154021541215422154321544215452154621547215482154921550215512155221553215542155521556215572155821559215602156121562215632156421565215662156721568215692157021571215722157321574215752157621577215782157921580215812158221583215842158521586215872158821589215902159121592215932159421595215962159721598215992160021601216022160321604216052160621607216082160921610216112161221613216142161521616216172161821619216202162121622216232162421625216262162721628216292163021631216322163321634216352163621637216382163921640216412164221643216442164521646216472164821649216502165121652216532165421655216562165721658216592166021661216622166321664216652166621667216682166921670216712167221673216742167521676216772167821679216802168121682216832168421685216862168721688216892169021691216922169321694216952169621697216982169921700217012170221703217042170521706217072170821709217102171121712217132171421715217162171721718217192172021721217222172321724217252172621727217282172921730217312173221733217342173521736217372173821739217402174121742217432174421745217462174721748217492175021751217522175321754217552175621757217582175921760217612176221763217642176521766217672176821769217702177121772217732177421775217762177721778217792178021781217822178321784217852178621787217882178921790217912179221793217942179521796217972179821799218002180121802218032180421805218062180721808218092181021811218122181321814218152181621817218182181921820218212182221823218242182521826218272182821829218302183121832218332183421835218362183721838218392184021841218422184321844218452184621847218482184921850218512185221853218542185521856218572185821859218602186121862218632186421865218662186721868218692187021871218722187321874218752187621877218782187921880218812188221883218842188521886218872188821889218902189121892218932189421895218962189721898218992190021901219022190321904219052190621907219082190921910219112191221913219142191521916219172191821919219202192121922219232192421925219262192721928219292193021931219322193321934219352193621937219382193921940219412194221943219442194521946219472194821949219502195121952219532195421955219562195721958219592196021961219622196321964219652196621967219682196921970219712197221973219742197521976219772197821979219802198121982219832198421985219862198721988219892199021991219922199321994219952199621997219982199922000220012200222003220042200522006220072200822009220102201122012220132201422015220162201722018220192202022021220222202322024220252202622027220282202922030220312203222033220342203522036220372203822039220402204122042220432204422045220462204722048220492205022051220522205322054220552205622057220582205922060220612206222063220642206522066220672206822069220702207122072220732207422075220762207722078220792208022081220822208322084220852208622087220882208922090220912209222093220942209522096220972209822099221002210122102221032210422105221062210722108221092211022111221122211322114221152211622117221182211922120221212212222123221242212522126221272212822129221302213122132221332213422135221362213722138221392214022141221422214322144221452214622147221482214922150221512215222153221542215522156221572215822159221602216122162221632216422165221662216722168221692217022171221722217322174221752217622177221782217922180221812218222183221842218522186221872218822189221902219122192221932219422195221962219722198221992220022201222022220322204222052220622207222082220922210222112221222213222142221522216222172221822219222202222122222222232222422225222262222722228222292223022231222322223322234222352223622237222382223922240222412224222243222442224522246222472224822249222502225122252222532225422255222562225722258222592226022261222622226322264222652226622267222682226922270222712227222273222742227522276222772227822279222802228122282222832228422285222862228722288222892229022291222922229322294222952229622297222982229922300223012230222303223042230522306223072230822309223102231122312223132231422315223162231722318223192232022321223222232322324223252232622327223282232922330223312233222333223342233522336223372233822339223402234122342223432234422345223462234722348223492235022351223522235322354223552235622357223582235922360223612236222363223642236522366223672236822369223702237122372223732237422375223762237722378223792238022381223822238322384223852238622387223882238922390223912239222393223942239522396223972239822399224002240122402224032240422405224062240722408224092241022411224122241322414224152241622417224182241922420224212242222423224242242522426224272242822429224302243122432224332243422435224362243722438224392244022441224422244322444224452244622447224482244922450224512245222453224542245522456224572245822459224602246122462224632246422465224662246722468224692247022471224722247322474224752247622477224782247922480224812248222483224842248522486224872248822489224902249122492224932249422495224962249722498224992250022501225022250322504225052250622507225082250922510225112251222513225142251522516225172251822519225202252122522225232252422525225262252722528225292253022531225322253322534225352253622537225382253922540225412254222543225442254522546225472254822549225502255122552225532255422555225562255722558225592256022561225622256322564225652256622567225682256922570225712257222573225742257522576225772257822579225802258122582225832258422585225862258722588225892259022591225922259322594225952259622597225982259922600226012260222603226042260522606226072260822609226102261122612226132261422615226162261722618226192262022621226222262322624226252262622627226282262922630226312263222633226342263522636226372263822639226402264122642226432264422645226462264722648226492265022651226522265322654226552265622657226582265922660226612266222663226642266522666226672266822669226702267122672226732267422675226762267722678226792268022681226822268322684226852268622687226882268922690226912269222693226942269522696226972269822699227002270122702227032270422705227062270722708227092271022711227122271322714227152271622717227182271922720227212272222723227242272522726227272272822729227302273122732227332273422735227362273722738227392274022741227422274322744227452274622747227482274922750227512275222753227542275522756227572275822759227602276122762227632276422765227662276722768227692277022771227722277322774227752277622777227782277922780227812278222783227842278522786227872278822789227902279122792227932279422795227962279722798227992280022801228022280322804228052280622807228082280922810228112281222813228142281522816228172281822819228202282122822228232282422825228262282722828228292283022831228322283322834228352283622837228382283922840228412284222843228442284522846228472284822849228502285122852228532285422855228562285722858228592286022861228622286322864228652286622867228682286922870228712287222873228742287522876228772287822879228802288122882228832288422885228862288722888228892289022891228922289322894228952289622897228982289922900229012290222903229042290522906229072290822909229102291122912229132291422915229162291722918229192292022921229222292322924229252292622927229282292922930229312293222933229342293522936229372293822939229402294122942229432294422945229462294722948229492295022951229522295322954229552295622957229582295922960229612296222963229642296522966229672296822969229702297122972229732297422975229762297722978229792298022981229822298322984229852298622987229882298922990229912299222993229942299522996229972299822999230002300123002230032300423005230062300723008230092301023011230122301323014230152301623017230182301923020230212302223023230242302523026230272302823029230302303123032230332303423035230362303723038230392304023041230422304323044230452304623047230482304923050230512305223053230542305523056230572305823059230602306123062230632306423065230662306723068230692307023071230722307323074230752307623077230782307923080230812308223083230842308523086230872308823089230902309123092230932309423095230962309723098230992310023101231022310323104231052310623107231082310923110231112311223113231142311523116231172311823119231202312123122231232312423125231262312723128231292313023131231322313323134231352313623137231382313923140231412314223143231442314523146231472314823149231502315123152231532315423155231562315723158231592316023161231622316323164231652316623167231682316923170231712317223173231742317523176231772317823179231802318123182231832318423185231862318723188231892319023191231922319323194231952319623197231982319923200232012320223203232042320523206232072320823209232102321123212232132321423215232162321723218232192322023221232222322323224232252322623227232282322923230232312323223233232342323523236232372323823239232402324123242232432324423245232462324723248232492325023251232522325323254232552325623257232582325923260232612326223263232642326523266232672326823269232702327123272232732327423275232762327723278232792328023281232822328323284232852328623287232882328923290232912329223293232942329523296232972329823299233002330123302233032330423305233062330723308233092331023311233122331323314233152331623317233182331923320233212332223323233242332523326233272332823329233302333123332233332333423335233362333723338233392334023341233422334323344233452334623347233482334923350233512335223353233542335523356233572335823359233602336123362233632336423365233662336723368233692337023371233722337323374233752337623377233782337923380233812338223383233842338523386233872338823389233902339123392233932339423395233962339723398233992340023401234022340323404234052340623407234082340923410234112341223413234142341523416234172341823419234202342123422234232342423425234262342723428234292343023431234322343323434234352343623437234382343923440234412344223443234442344523446234472344823449234502345123452234532345423455234562345723458234592346023461234622346323464234652346623467234682346923470234712347223473234742347523476234772347823479234802348123482234832348423485234862348723488234892349023491234922349323494234952349623497234982349923500235012350223503235042350523506235072350823509235102351123512235132351423515235162351723518235192352023521235222352323524235252352623527235282352923530235312353223533235342353523536235372353823539235402354123542235432354423545235462354723548235492355023551235522355323554235552355623557235582355923560235612356223563235642356523566235672356823569235702357123572235732357423575235762357723578235792358023581235822358323584235852358623587235882358923590235912359223593235942359523596235972359823599236002360123602236032360423605236062360723608236092361023611236122361323614236152361623617236182361923620236212362223623236242362523626236272362823629236302363123632236332363423635236362363723638236392364023641236422364323644236452364623647236482364923650236512365223653236542365523656236572365823659236602366123662236632366423665236662366723668236692367023671236722367323674236752367623677236782367923680236812368223683236842368523686236872368823689236902369123692236932369423695236962369723698236992370023701237022370323704237052370623707237082370923710237112371223713237142371523716237172371823719237202372123722237232372423725237262372723728237292373023731237322373323734237352373623737237382373923740237412374223743237442374523746237472374823749237502375123752237532375423755237562375723758237592376023761237622376323764237652376623767237682376923770237712377223773237742377523776237772377823779237802378123782237832378423785237862378723788237892379023791237922379323794237952379623797237982379923800238012380223803238042380523806238072380823809238102381123812238132381423815238162381723818238192382023821238222382323824238252382623827238282382923830238312383223833238342383523836238372383823839238402384123842238432384423845238462384723848238492385023851238522385323854238552385623857238582385923860238612386223863238642386523866238672386823869238702387123872238732387423875238762387723878238792388023881238822388323884238852388623887238882388923890238912389223893238942389523896238972389823899239002390123902239032390423905239062390723908239092391023911239122391323914239152391623917239182391923920239212392223923239242392523926239272392823929239302393123932239332393423935239362393723938239392394023941239422394323944239452394623947239482394923950239512395223953239542395523956239572395823959239602396123962239632396423965239662396723968239692397023971239722397323974239752397623977239782397923980239812398223983239842398523986239872398823989239902399123992239932399423995239962399723998239992400024001240022400324004240052400624007240082400924010240112401224013240142401524016240172401824019240202402124022240232402424025240262402724028240292403024031240322403324034240352403624037240382403924040240412404224043240442404524046240472404824049240502405124052240532405424055240562405724058240592406024061240622406324064240652406624067240682406924070240712407224073240742407524076240772407824079240802408124082240832408424085240862408724088240892409024091240922409324094240952409624097240982409924100241012410224103241042410524106241072410824109241102411124112241132411424115241162411724118241192412024121241222412324124241252412624127241282412924130241312413224133241342413524136241372413824139241402414124142241432414424145241462414724148241492415024151241522415324154241552415624157241582415924160241612416224163241642416524166241672416824169241702417124172241732417424175241762417724178241792418024181241822418324184241852418624187241882418924190241912419224193241942419524196241972419824199242002420124202242032420424205242062420724208242092421024211242122421324214242152421624217242182421924220242212422224223242242422524226242272422824229242302423124232242332423424235242362423724238242392424024241242422424324244242452424624247242482424924250242512425224253242542425524256242572425824259242602426124262242632426424265242662426724268242692427024271242722427324274242752427624277242782427924280242812428224283242842428524286242872428824289242902429124292242932429424295242962429724298242992430024301243022430324304243052430624307243082430924310243112431224313243142431524316243172431824319243202432124322243232432424325243262432724328243292433024331243322433324334243352433624337243382433924340243412434224343243442434524346243472434824349243502435124352243532435424355243562435724358243592436024361243622436324364243652436624367243682436924370243712437224373243742437524376243772437824379243802438124382243832438424385243862438724388243892439024391243922439324394243952439624397243982439924400244012440224403244042440524406244072440824409244102441124412244132441424415244162441724418244192442024421244222442324424244252442624427244282442924430244312443224433244342443524436244372443824439244402444124442244432444424445244462444724448244492445024451244522445324454244552445624457244582445924460244612446224463244642446524466244672446824469244702447124472244732447424475244762447724478244792448024481244822448324484244852448624487244882448924490244912449224493244942449524496244972449824499245002450124502245032450424505245062450724508245092451024511245122451324514245152451624517245182451924520245212452224523245242452524526245272452824529245302453124532245332453424535245362453724538245392454024541245422454324544245452454624547245482454924550245512455224553245542455524556245572455824559245602456124562245632456424565245662456724568245692457024571245722457324574245752457624577245782457924580245812458224583245842458524586245872458824589245902459124592245932459424595245962459724598245992460024601246022460324604246052460624607246082460924610246112461224613246142461524616246172461824619246202462124622246232462424625246262462724628246292463024631246322463324634246352463624637246382463924640246412464224643246442464524646246472464824649246502465124652246532465424655246562465724658246592466024661246622466324664246652466624667246682466924670246712467224673246742467524676246772467824679246802468124682246832468424685246862468724688246892469024691246922469324694246952469624697246982469924700247012470224703247042470524706247072470824709247102471124712247132471424715247162471724718247192472024721247222472324724247252472624727247282472924730247312473224733247342473524736247372473824739247402474124742247432474424745247462474724748247492475024751247522475324754247552475624757247582475924760247612476224763247642476524766247672476824769247702477124772247732477424775247762477724778247792478024781247822478324784247852478624787247882478924790247912479224793247942479524796247972479824799248002480124802248032480424805248062480724808248092481024811248122481324814248152481624817248182481924820248212482224823248242482524826248272482824829248302483124832248332483424835248362483724838248392484024841248422484324844248452484624847248482484924850248512485224853248542485524856248572485824859248602486124862248632486424865248662486724868248692487024871248722487324874248752487624877248782487924880248812488224883248842488524886248872488824889248902489124892248932489424895248962489724898248992490024901249022490324904249052490624907249082490924910249112491224913249142491524916249172491824919249202492124922249232492424925249262492724928249292493024931249322493324934249352493624937249382493924940249412494224943249442494524946249472494824949249502495124952249532495424955249562495724958249592496024961249622496324964249652496624967249682496924970249712497224973249742497524976249772497824979249802498124982249832498424985249862498724988249892499024991249922499324994249952499624997249982499925000250012500225003250042500525006250072500825009250102501125012250132501425015250162501725018250192502025021250222502325024250252502625027250282502925030250312503225033250342503525036250372503825039250402504125042250432504425045250462504725048250492505025051250522505325054250552505625057250582505925060250612506225063250642506525066250672506825069250702507125072250732507425075250762507725078250792508025081250822508325084250852508625087250882508925090250912509225093250942509525096250972509825099251002510125102251032510425105251062510725108251092511025111251122511325114251152511625117251182511925120251212512225123251242512525126251272512825129251302513125132251332513425135251362513725138251392514025141251422514325144251452514625147251482514925150251512515225153251542515525156251572515825159251602516125162251632516425165251662516725168251692517025171251722517325174251752517625177251782517925180251812518225183251842518525186251872518825189251902519125192251932519425195251962519725198251992520025201252022520325204252052520625207252082520925210252112521225213252142521525216252172521825219252202522125222252232522425225252262522725228252292523025231252322523325234252352523625237252382523925240252412524225243252442524525246252472524825249252502525125252252532525425255252562525725258252592526025261252622526325264252652526625267252682526925270252712527225273252742527525276252772527825279252802528125282252832528425285252862528725288252892529025291252922529325294252952529625297252982529925300253012530225303253042530525306253072530825309253102531125312253132531425315253162531725318253192532025321253222532325324253252532625327253282532925330253312533225333253342533525336253372533825339253402534125342253432534425345253462534725348253492535025351253522535325354253552535625357253582535925360253612536225363253642536525366253672536825369253702537125372253732537425375253762537725378253792538025381253822538325384253852538625387253882538925390253912539225393253942539525396253972539825399254002540125402254032540425405254062540725408254092541025411254122541325414254152541625417254182541925420254212542225423254242542525426254272542825429254302543125432254332543425435254362543725438254392544025441254422544325444254452544625447254482544925450254512545225453254542545525456254572545825459254602546125462254632546425465254662546725468254692547025471254722547325474254752547625477254782547925480254812548225483254842548525486254872548825489254902549125492254932549425495254962549725498254992550025501255022550325504255052550625507255082550925510255112551225513255142551525516255172551825519255202552125522255232552425525255262552725528255292553025531255322553325534255352553625537255382553925540255412554225543255442554525546255472554825549255502555125552255532555425555255562555725558255592556025561255622556325564255652556625567255682556925570255712557225573255742557525576255772557825579255802558125582255832558425585255862558725588255892559025591255922559325594255952559625597255982559925600256012560225603256042560525606256072560825609256102561125612256132561425615256162561725618256192562025621256222562325624256252562625627256282562925630256312563225633256342563525636256372563825639256402564125642256432564425645256462564725648256492565025651256522565325654256552565625657256582565925660256612566225663256642566525666256672566825669256702567125672256732567425675256762567725678256792568025681256822568325684256852568625687256882568925690256912569225693256942569525696256972569825699257002570125702257032570425705257062570725708257092571025711257122571325714257152571625717257182571925720257212572225723257242572525726257272572825729257302573125732257332573425735257362573725738257392574025741257422574325744257452574625747257482574925750257512575225753257542575525756257572575825759257602576125762257632576425765257662576725768257692577025771257722577325774257752577625777257782577925780257812578225783257842578525786257872578825789257902579125792257932579425795257962579725798257992580025801258022580325804258052580625807258082580925810258112581225813258142581525816258172581825819258202582125822258232582425825258262582725828258292583025831258322583325834258352583625837258382583925840258412584225843258442584525846258472584825849258502585125852258532585425855258562585725858258592586025861258622586325864258652586625867258682586925870258712587225873258742587525876258772587825879258802588125882258832588425885258862588725888258892589025891258922589325894258952589625897258982589925900259012590225903259042590525906259072590825909259102591125912259132591425915259162591725918259192592025921259222592325924259252592625927259282592925930259312593225933259342593525936259372593825939259402594125942259432594425945259462594725948259492595025951259522595325954259552595625957259582595925960259612596225963259642596525966259672596825969259702597125972259732597425975259762597725978259792598025981259822598325984259852598625987259882598925990259912599225993259942599525996259972599825999260002600126002260032600426005260062600726008260092601026011260122601326014260152601626017260182601926020260212602226023260242602526026260272602826029260302603126032260332603426035260362603726038260392604026041260422604326044260452604626047260482604926050260512605226053260542605526056260572605826059260602606126062260632606426065260662606726068260692607026071260722607326074260752607626077260782607926080260812608226083260842608526086260872608826089260902609126092260932609426095260962609726098260992610026101261022610326104261052610626107261082610926110261112611226113261142611526116261172611826119261202612126122261232612426125261262612726128261292613026131261322613326134261352613626137261382613926140261412614226143261442614526146261472614826149261502615126152261532615426155261562615726158261592616026161261622616326164261652616626167261682616926170261712617226173261742617526176261772617826179261802618126182261832618426185261862618726188261892619026191261922619326194261952619626197261982619926200262012620226203262042620526206262072620826209262102621126212262132621426215262162621726218262192622026221262222622326224262252622626227262282622926230262312623226233262342623526236262372623826239262402624126242262432624426245262462624726248262492625026251262522625326254262552625626257262582625926260262612626226263262642626526266262672626826269262702627126272262732627426275262762627726278262792628026281262822628326284262852628626287262882628926290262912629226293262942629526296262972629826299263002630126302263032630426305263062630726308263092631026311263122631326314263152631626317263182631926320263212632226323263242632526326263272632826329263302633126332263332633426335263362633726338263392634026341263422634326344263452634626347263482634926350263512635226353263542635526356263572635826359263602636126362263632636426365263662636726368263692637026371263722637326374263752637626377263782637926380263812638226383263842638526386263872638826389263902639126392263932639426395263962639726398263992640026401264022640326404264052640626407264082640926410264112641226413264142641526416264172641826419264202642126422264232642426425264262642726428264292643026431264322643326434264352643626437264382643926440264412644226443264442644526446264472644826449264502645126452264532645426455264562645726458264592646026461264622646326464264652646626467264682646926470264712647226473264742647526476264772647826479264802648126482264832648426485264862648726488264892649026491264922649326494264952649626497264982649926500265012650226503265042650526506265072650826509265102651126512265132651426515265162651726518265192652026521265222652326524265252652626527265282652926530265312653226533265342653526536265372653826539265402654126542265432654426545265462654726548265492655026551265522655326554265552655626557265582655926560265612656226563265642656526566265672656826569265702657126572265732657426575265762657726578265792658026581265822658326584265852658626587265882658926590265912659226593265942659526596265972659826599266002660126602266032660426605266062660726608266092661026611266122661326614266152661626617266182661926620266212662226623266242662526626266272662826629266302663126632266332663426635266362663726638266392664026641266422664326644266452664626647266482664926650266512665226653266542665526656266572665826659266602666126662266632666426665266662666726668266692667026671266722667326674266752667626677266782667926680266812668226683266842668526686266872668826689266902669126692266932669426695266962669726698266992670026701267022670326704267052670626707267082670926710267112671226713267142671526716267172671826719267202672126722267232672426725267262672726728267292673026731267322673326734267352673626737267382673926740267412674226743267442674526746267472674826749267502675126752267532675426755267562675726758267592676026761267622676326764267652676626767267682676926770267712677226773267742677526776267772677826779267802678126782267832678426785267862678726788267892679026791267922679326794267952679626797267982679926800268012680226803268042680526806268072680826809268102681126812268132681426815268162681726818268192682026821268222682326824268252682626827268282682926830268312683226833268342683526836268372683826839268402684126842268432684426845268462684726848268492685026851268522685326854268552685626857268582685926860268612686226863268642686526866268672686826869268702687126872268732687426875268762687726878268792688026881268822688326884268852688626887268882688926890268912689226893268942689526896268972689826899269002690126902269032690426905269062690726908269092691026911269122691326914269152691626917269182691926920269212692226923269242692526926269272692826929269302693126932269332693426935269362693726938269392694026941269422694326944269452694626947269482694926950269512695226953269542695526956269572695826959269602696126962269632696426965269662696726968269692697026971269722697326974269752697626977269782697926980269812698226983269842698526986269872698826989269902699126992269932699426995269962699726998269992700027001270022700327004270052700627007270082700927010270112701227013270142701527016270172701827019270202702127022270232702427025270262702727028270292703027031270322703327034270352703627037270382703927040270412704227043270442704527046270472704827049270502705127052270532705427055270562705727058270592706027061270622706327064270652706627067270682706927070270712707227073270742707527076270772707827079270802708127082270832708427085270862708727088270892709027091270922709327094270952709627097270982709927100271012710227103271042710527106271072710827109271102711127112271132711427115271162711727118271192712027121271222712327124271252712627127271282712927130271312713227133271342713527136271372713827139271402714127142271432714427145271462714727148271492715027151271522715327154271552715627157271582715927160271612716227163271642716527166271672716827169271702717127172271732717427175271762717727178271792718027181271822718327184271852718627187271882718927190271912719227193271942719527196271972719827199272002720127202272032720427205272062720727208272092721027211272122721327214272152721627217272182721927220272212722227223272242722527226272272722827229272302723127232272332723427235272362723727238272392724027241272422724327244272452724627247272482724927250272512725227253272542725527256272572725827259272602726127262272632726427265272662726727268272692727027271272722727327274272752727627277272782727927280272812728227283272842728527286272872728827289272902729127292272932729427295272962729727298272992730027301273022730327304273052730627307273082730927310273112731227313273142731527316273172731827319273202732127322273232732427325273262732727328273292733027331273322733327334273352733627337273382733927340273412734227343273442734527346273472734827349273502735127352273532735427355273562735727358273592736027361273622736327364273652736627367273682736927370273712737227373273742737527376273772737827379273802738127382273832738427385273862738727388273892739027391273922739327394273952739627397273982739927400274012740227403274042740527406274072740827409274102741127412274132741427415274162741727418274192742027421274222742327424274252742627427274282742927430274312743227433274342743527436274372743827439274402744127442274432744427445274462744727448274492745027451274522745327454274552745627457274582745927460274612746227463274642746527466274672746827469274702747127472274732747427475274762747727478274792748027481274822748327484274852748627487274882748927490274912749227493274942749527496274972749827499275002750127502275032750427505275062750727508275092751027511275122751327514275152751627517275182751927520275212752227523275242752527526275272752827529275302753127532275332753427535275362753727538275392754027541275422754327544275452754627547275482754927550275512755227553275542755527556275572755827559275602756127562275632756427565275662756727568275692757027571275722757327574275752757627577275782757927580275812758227583275842758527586275872758827589275902759127592275932759427595275962759727598275992760027601276022760327604276052760627607276082760927610276112761227613276142761527616276172761827619276202762127622276232762427625276262762727628276292763027631276322763327634276352763627637276382763927640276412764227643276442764527646276472764827649276502765127652276532765427655276562765727658276592766027661276622766327664276652766627667276682766927670276712767227673276742767527676276772767827679276802768127682276832768427685276862768727688276892769027691276922769327694276952769627697276982769927700277012770227703277042770527706277072770827709277102771127712277132771427715277162771727718277192772027721277222772327724277252772627727277282772927730277312773227733277342773527736277372773827739277402774127742277432774427745277462774727748277492775027751277522775327754277552775627757277582775927760277612776227763277642776527766277672776827769277702777127772277732777427775277762777727778277792778027781277822778327784277852778627787277882778927790277912779227793277942779527796277972779827799278002780127802278032780427805278062780727808278092781027811278122781327814278152781627817278182781927820278212782227823278242782527826278272782827829278302783127832278332783427835278362783727838278392784027841278422784327844278452784627847278482784927850278512785227853278542785527856278572785827859278602786127862278632786427865278662786727868278692787027871278722787327874278752787627877278782787927880278812788227883278842788527886278872788827889278902789127892278932789427895278962789727898278992790027901279022790327904279052790627907279082790927910279112791227913279142791527916279172791827919279202792127922279232792427925279262792727928279292793027931279322793327934279352793627937279382793927940279412794227943279442794527946279472794827949279502795127952279532795427955279562795727958279592796027961279622796327964279652796627967279682796927970279712797227973279742797527976279772797827979279802798127982279832798427985279862798727988279892799027991279922799327994279952799627997279982799928000280012800228003280042800528006280072800828009280102801128012280132801428015280162801728018280192802028021280222802328024280252802628027280282802928030280312803228033280342803528036280372803828039280402804128042280432804428045280462804728048280492805028051280522805328054280552805628057280582805928060280612806228063280642806528066280672806828069280702807128072280732807428075280762807728078280792808028081280822808328084280852808628087280882808928090280912809228093280942809528096280972809828099281002810128102281032810428105281062810728108281092811028111281122811328114281152811628117281182811928120281212812228123281242812528126281272812828129281302813128132281332813428135281362813728138281392814028141281422814328144281452814628147281482814928150281512815228153281542815528156281572815828159281602816128162281632816428165281662816728168281692817028171281722817328174281752817628177281782817928180281812818228183281842818528186281872818828189281902819128192281932819428195281962819728198281992820028201282022820328204282052820628207282082820928210282112821228213282142821528216282172821828219282202822128222282232822428225282262822728228282292823028231282322823328234282352823628237282382823928240282412824228243282442824528246282472824828249282502825128252282532825428255282562825728258282592826028261282622826328264282652826628267282682826928270282712827228273282742827528276282772827828279282802828128282282832828428285282862828728288282892829028291282922829328294282952829628297282982829928300283012830228303283042830528306283072830828309283102831128312283132831428315283162831728318283192832028321283222832328324283252832628327283282832928330283312833228333283342833528336283372833828339283402834128342283432834428345283462834728348283492835028351283522835328354283552835628357283582835928360283612836228363283642836528366283672836828369283702837128372283732837428375283762837728378283792838028381283822838328384283852838628387283882838928390283912839228393283942839528396283972839828399284002840128402284032840428405284062840728408284092841028411284122841328414284152841628417284182841928420284212842228423284242842528426284272842828429284302843128432284332843428435284362843728438284392844028441284422844328444284452844628447284482844928450284512845228453284542845528456284572845828459284602846128462284632846428465284662846728468284692847028471284722847328474284752847628477284782847928480284812848228483284842848528486284872848828489284902849128492284932849428495284962849728498284992850028501285022850328504285052850628507285082850928510285112851228513285142851528516285172851828519285202852128522285232852428525285262852728528285292853028531285322853328534285352853628537285382853928540285412854228543285442854528546285472854828549285502855128552285532855428555285562855728558285592856028561285622856328564285652856628567285682856928570285712857228573285742857528576285772857828579285802858128582285832858428585285862858728588285892859028591285922859328594285952859628597285982859928600286012860228603286042860528606286072860828609286102861128612286132861428615286162861728618286192862028621286222862328624286252862628627286282862928630286312863228633286342863528636286372863828639286402864128642286432864428645286462864728648286492865028651286522865328654286552865628657286582865928660286612866228663286642866528666286672866828669286702867128672286732867428675286762867728678286792868028681286822868328684286852868628687286882868928690286912869228693286942869528696286972869828699287002870128702287032870428705287062870728708287092871028711287122871328714287152871628717287182871928720287212872228723287242872528726287272872828729287302873128732287332873428735287362873728738287392874028741287422874328744287452874628747287482874928750287512875228753287542875528756287572875828759287602876128762287632876428765287662876728768287692877028771287722877328774287752877628777287782877928780287812878228783287842878528786287872878828789287902879128792287932879428795287962879728798287992880028801288022880328804288052880628807288082880928810288112881228813288142881528816288172881828819288202882128822288232882428825288262882728828288292883028831288322883328834288352883628837288382883928840288412884228843288442884528846288472884828849288502885128852288532885428855288562885728858288592886028861288622886328864288652886628867288682886928870288712887228873288742887528876288772887828879288802888128882288832888428885288862888728888288892889028891288922889328894288952889628897288982889928900289012890228903289042890528906289072890828909289102891128912289132891428915289162891728918289192892028921289222892328924289252892628927289282892928930289312893228933289342893528936289372893828939289402894128942289432894428945289462894728948289492895028951289522895328954289552895628957289582895928960289612896228963289642896528966289672896828969289702897128972289732897428975289762897728978289792898028981289822898328984289852898628987289882898928990289912899228993289942899528996289972899828999290002900129002290032900429005290062900729008290092901029011290122901329014290152901629017290182901929020290212902229023290242902529026290272902829029290302903129032290332903429035290362903729038290392904029041290422904329044290452904629047290482904929050290512905229053290542905529056290572905829059290602906129062290632906429065290662906729068290692907029071290722907329074290752907629077290782907929080290812908229083290842908529086290872908829089290902909129092290932909429095290962909729098290992910029101291022910329104291052910629107291082910929110291112911229113291142911529116291172911829119291202912129122291232912429125291262912729128291292913029131291322913329134291352913629137291382913929140291412914229143291442914529146291472914829149291502915129152291532915429155291562915729158291592916029161291622916329164291652916629167291682916929170291712917229173291742917529176291772917829179291802918129182291832918429185291862918729188291892919029191291922919329194291952919629197291982919929200292012920229203292042920529206292072920829209292102921129212292132921429215292162921729218292192922029221292222922329224292252922629227292282922929230292312923229233292342923529236292372923829239292402924129242292432924429245292462924729248292492925029251292522925329254292552925629257292582925929260292612926229263292642926529266292672926829269292702927129272292732927429275292762927729278292792928029281292822928329284292852928629287292882928929290292912929229293292942929529296292972929829299293002930129302293032930429305293062930729308293092931029311293122931329314293152931629317293182931929320293212932229323293242932529326293272932829329293302933129332293332933429335293362933729338293392934029341293422934329344293452934629347293482934929350293512935229353293542935529356293572935829359293602936129362293632936429365293662936729368293692937029371293722937329374293752937629377293782937929380293812938229383293842938529386293872938829389293902939129392293932939429395293962939729398293992940029401294022940329404294052940629407294082940929410294112941229413294142941529416294172941829419294202942129422294232942429425294262942729428294292943029431294322943329434294352943629437294382943929440294412944229443294442944529446294472944829449294502945129452294532945429455294562945729458294592946029461294622946329464294652946629467294682946929470294712947229473294742947529476294772947829479294802948129482294832948429485294862948729488294892949029491294922949329494294952949629497294982949929500295012950229503295042950529506295072950829509295102951129512295132951429515295162951729518295192952029521295222952329524295252952629527295282952929530295312953229533295342953529536295372953829539295402954129542295432954429545295462954729548295492955029551295522955329554295552955629557295582955929560295612956229563295642956529566295672956829569295702957129572295732957429575295762957729578295792958029581295822958329584295852958629587295882958929590295912959229593295942959529596295972959829599296002960129602296032960429605296062960729608296092961029611296122961329614296152961629617296182961929620296212962229623296242962529626296272962829629296302963129632296332963429635296362963729638296392964029641296422964329644296452964629647296482964929650296512965229653296542965529656296572965829659296602966129662296632966429665296662966729668296692967029671296722967329674296752967629677296782967929680296812968229683296842968529686296872968829689296902969129692296932969429695296962969729698296992970029701297022970329704297052970629707297082970929710297112971229713297142971529716297172971829719297202972129722297232972429725297262972729728297292973029731297322973329734297352973629737297382973929740297412974229743297442974529746297472974829749297502975129752297532975429755297562975729758297592976029761297622976329764297652976629767297682976929770297712977229773297742977529776297772977829779297802978129782297832978429785297862978729788297892979029791297922979329794297952979629797297982979929800298012980229803298042980529806298072980829809298102981129812298132981429815298162981729818298192982029821298222982329824298252982629827298282982929830298312983229833298342983529836298372983829839298402984129842298432984429845298462984729848298492985029851298522985329854298552985629857298582985929860298612986229863298642986529866298672986829869298702987129872298732987429875298762987729878298792988029881298822988329884298852988629887298882988929890298912989229893298942989529896298972989829899299002990129902299032990429905299062990729908299092991029911299122991329914299152991629917299182991929920299212992229923299242992529926299272992829929299302993129932299332993429935299362993729938299392994029941299422994329944299452994629947299482994929950299512995229953299542995529956299572995829959299602996129962299632996429965299662996729968299692997029971299722997329974299752997629977299782997929980299812998229983299842998529986299872998829989299902999129992299932999429995299962999729998299993000030001300023000330004300053000630007300083000930010300113001230013300143001530016300173001830019300203002130022300233002430025300263002730028300293003030031300323003330034300353003630037300383003930040300413004230043300443004530046300473004830049300503005130052300533005430055300563005730058300593006030061300623006330064300653006630067300683006930070300713007230073300743007530076300773007830079300803008130082300833008430085300863008730088300893009030091300923009330094300953009630097300983009930100301013010230103301043010530106301073010830109301103011130112301133011430115301163011730118301193012030121301223012330124301253012630127301283012930130301313013230133301343013530136301373013830139301403014130142301433014430145301463014730148301493015030151301523015330154301553015630157301583015930160301613016230163301643016530166301673016830169301703017130172301733017430175301763017730178301793018030181301823018330184301853018630187301883018930190301913019230193301943019530196301973019830199302003020130202302033020430205302063020730208302093021030211302123021330214302153021630217302183021930220302213022230223302243022530226302273022830229302303023130232302333023430235302363023730238302393024030241302423024330244302453024630247302483024930250302513025230253302543025530256302573025830259302603026130262302633026430265302663026730268302693027030271302723027330274302753027630277302783027930280302813028230283302843028530286302873028830289302903029130292302933029430295302963029730298302993030030301303023030330304303053030630307303083030930310303113031230313303143031530316303173031830319303203032130322303233032430325303263032730328303293033030331303323033330334303353033630337303383033930340303413034230343303443034530346303473034830349303503035130352303533035430355303563035730358303593036030361303623036330364303653036630367303683036930370303713037230373303743037530376303773037830379303803038130382303833038430385303863038730388303893039030391303923039330394303953039630397303983039930400304013040230403304043040530406304073040830409304103041130412304133041430415304163041730418304193042030421304223042330424304253042630427304283042930430304313043230433304343043530436304373043830439304403044130442304433044430445304463044730448304493045030451304523045330454304553045630457304583045930460304613046230463304643046530466304673046830469304703047130472304733047430475304763047730478304793048030481304823048330484304853048630487304883048930490304913049230493304943049530496304973049830499305003050130502305033050430505305063050730508305093051030511305123051330514305153051630517305183051930520305213052230523305243052530526305273052830529305303053130532305333053430535305363053730538305393054030541305423054330544305453054630547305483054930550305513055230553305543055530556305573055830559305603056130562305633056430565305663056730568305693057030571305723057330574305753057630577305783057930580305813058230583305843058530586305873058830589305903059130592305933059430595305963059730598305993060030601306023060330604306053060630607306083060930610306113061230613306143061530616306173061830619306203062130622306233062430625306263062730628306293063030631306323063330634306353063630637306383063930640306413064230643306443064530646306473064830649306503065130652306533065430655306563065730658306593066030661306623066330664306653066630667306683066930670306713067230673306743067530676306773067830679306803068130682306833068430685306863068730688306893069030691306923069330694306953069630697306983069930700307013070230703307043070530706307073070830709307103071130712307133071430715307163071730718307193072030721307223072330724307253072630727307283072930730307313073230733307343073530736307373073830739307403074130742307433074430745307463074730748307493075030751307523075330754307553075630757307583075930760307613076230763307643076530766307673076830769307703077130772307733077430775307763077730778307793078030781307823078330784307853078630787307883078930790307913079230793307943079530796307973079830799308003080130802308033080430805308063080730808308093081030811308123081330814308153081630817308183081930820308213082230823308243082530826308273082830829308303083130832308333083430835308363083730838308393084030841308423084330844308453084630847308483084930850308513085230853308543085530856308573085830859308603086130862308633086430865308663086730868308693087030871308723087330874308753087630877308783087930880308813088230883308843088530886308873088830889308903089130892308933089430895308963089730898308993090030901309023090330904309053090630907309083090930910309113091230913309143091530916309173091830919309203092130922309233092430925309263092730928309293093030931309323093330934309353093630937309383093930940309413094230943309443094530946309473094830949309503095130952309533095430955309563095730958309593096030961309623096330964309653096630967309683096930970309713097230973309743097530976309773097830979309803098130982309833098430985309863098730988309893099030991309923099330994309953099630997309983099931000310013100231003310043100531006310073100831009310103101131012310133101431015310163101731018310193102031021310223102331024310253102631027310283102931030310313103231033310343103531036310373103831039310403104131042310433104431045310463104731048310493105031051310523105331054310553105631057310583105931060310613106231063310643106531066310673106831069310703107131072310733107431075310763107731078310793108031081310823108331084310853108631087310883108931090310913109231093310943109531096310973109831099311003110131102311033110431105311063110731108311093111031111311123111331114311153111631117311183111931120311213112231123311243112531126311273112831129311303113131132311333113431135311363113731138311393114031141311423114331144311453114631147311483114931150311513115231153311543115531156311573115831159311603116131162311633116431165311663116731168311693117031171311723117331174311753117631177311783117931180311813118231183311843118531186311873118831189311903119131192311933119431195311963119731198311993120031201312023120331204312053120631207312083120931210312113121231213312143121531216312173121831219312203122131222312233122431225312263122731228312293123031231312323123331234312353123631237312383123931240312413124231243312443124531246312473124831249312503125131252312533125431255312563125731258312593126031261312623126331264312653126631267312683126931270312713127231273312743127531276312773127831279312803128131282312833128431285312863128731288312893129031291312923129331294312953129631297312983129931300313013130231303313043130531306313073130831309313103131131312313133131431315313163131731318313193132031321313223132331324313253132631327313283132931330313313133231333313343133531336313373133831339313403134131342313433134431345313463134731348313493135031351313523135331354313553135631357313583135931360313613136231363313643136531366313673136831369313703137131372313733137431375313763137731378313793138031381313823138331384313853138631387313883138931390313913139231393313943139531396313973139831399314003140131402314033140431405314063140731408314093141031411314123141331414314153141631417314183141931420314213142231423314243142531426314273142831429314303143131432314333143431435314363143731438314393144031441314423144331444314453144631447314483144931450314513145231453314543145531456314573145831459314603146131462314633146431465314663146731468314693147031471314723147331474314753147631477314783147931480314813148231483314843148531486314873148831489314903149131492314933149431495314963149731498314993150031501315023150331504315053150631507315083150931510315113151231513315143151531516315173151831519315203152131522315233152431525315263152731528315293153031531315323153331534315353153631537315383153931540315413154231543315443154531546315473154831549315503155131552315533155431555315563155731558315593156031561315623156331564315653156631567315683156931570315713157231573315743157531576315773157831579315803158131582315833158431585315863158731588315893159031591315923159331594315953159631597315983159931600316013160231603316043160531606316073160831609316103161131612316133161431615316163161731618316193162031621316223162331624316253162631627316283162931630316313163231633316343163531636316373163831639316403164131642316433164431645316463164731648316493165031651316523165331654316553165631657316583165931660316613166231663316643166531666316673166831669316703167131672316733167431675316763167731678316793168031681316823168331684316853168631687316883168931690316913169231693316943169531696316973169831699317003170131702317033170431705317063170731708317093171031711317123171331714317153171631717317183171931720317213172231723317243172531726317273172831729317303173131732317333173431735317363173731738317393174031741317423174331744317453174631747317483174931750317513175231753317543175531756317573175831759317603176131762317633176431765317663176731768317693177031771317723177331774317753177631777317783177931780317813178231783317843178531786317873178831789317903179131792317933179431795317963179731798317993180031801318023180331804318053180631807318083180931810318113181231813318143181531816318173181831819318203182131822318233182431825318263182731828318293183031831318323183331834318353183631837318383183931840318413184231843318443184531846318473184831849318503185131852318533185431855318563185731858318593186031861318623186331864318653186631867318683186931870318713187231873318743187531876318773187831879318803188131882318833188431885318863188731888318893189031891318923189331894318953189631897318983189931900319013190231903319043190531906319073190831909319103191131912319133191431915319163191731918319193192031921319223192331924319253192631927319283192931930319313193231933319343193531936319373193831939319403194131942319433194431945319463194731948319493195031951319523195331954319553195631957319583195931960319613196231963319643196531966319673196831969319703197131972319733197431975319763197731978319793198031981319823198331984319853198631987319883198931990319913199231993319943199531996319973199831999320003200132002320033200432005320063200732008320093201032011320123201332014320153201632017320183201932020320213202232023320243202532026320273202832029320303203132032320333203432035320363203732038320393204032041320423204332044320453204632047320483204932050320513205232053320543205532056320573205832059320603206132062320633206432065320663206732068320693207032071320723207332074320753207632077320783207932080320813208232083320843208532086320873208832089320903209132092320933209432095320963209732098320993210032101321023210332104321053210632107321083210932110321113211232113321143211532116321173211832119321203212132122321233212432125321263212732128321293213032131321323213332134321353213632137321383213932140321413214232143321443214532146321473214832149321503215132152321533215432155321563215732158321593216032161321623216332164321653216632167321683216932170321713217232173321743217532176321773217832179321803218132182321833218432185321863218732188321893219032191321923219332194321953219632197321983219932200322013220232203322043220532206322073220832209322103221132212322133221432215322163221732218322193222032221322223222332224322253222632227322283222932230322313223232233322343223532236322373223832239322403224132242322433224432245322463224732248322493225032251322523225332254322553225632257322583225932260322613226232263322643226532266322673226832269322703227132272322733227432275322763227732278322793228032281322823228332284322853228632287322883228932290322913229232293322943229532296322973229832299323003230132302323033230432305323063230732308323093231032311323123231332314323153231632317323183231932320323213232232323323243232532326323273232832329323303233132332323333233432335323363233732338323393234032341323423234332344323453234632347323483234932350323513235232353323543235532356323573235832359323603236132362323633236432365323663236732368323693237032371323723237332374323753237632377323783237932380323813238232383323843238532386323873238832389323903239132392323933239432395323963239732398323993240032401324023240332404324053240632407324083240932410324113241232413324143241532416324173241832419324203242132422324233242432425324263242732428324293243032431324323243332434324353243632437324383243932440324413244232443324443244532446324473244832449324503245132452324533245432455324563245732458324593246032461324623246332464324653246632467324683246932470324713247232473324743247532476324773247832479324803248132482324833248432485324863248732488324893249032491324923249332494324953249632497324983249932500325013250232503325043250532506325073250832509325103251132512325133251432515325163251732518325193252032521325223252332524325253252632527325283252932530325313253232533325343253532536325373253832539325403254132542325433254432545325463254732548325493255032551325523255332554325553255632557325583255932560325613256232563325643256532566325673256832569325703257132572325733257432575325763257732578325793258032581325823258332584325853258632587325883258932590325913259232593325943259532596325973259832599326003260132602326033260432605326063260732608326093261032611326123261332614326153261632617326183261932620326213262232623326243262532626326273262832629326303263132632326333263432635326363263732638326393264032641326423264332644326453264632647326483264932650326513265232653326543265532656326573265832659326603266132662326633266432665326663266732668326693267032671326723267332674326753267632677326783267932680326813268232683326843268532686326873268832689326903269132692326933269432695326963269732698326993270032701327023270332704327053270632707327083270932710327113271232713327143271532716327173271832719327203272132722327233272432725327263272732728327293273032731327323273332734327353273632737327383273932740327413274232743327443274532746327473274832749327503275132752327533275432755327563275732758327593276032761327623276332764327653276632767327683276932770327713277232773327743277532776327773277832779327803278132782327833278432785327863278732788327893279032791327923279332794327953279632797327983279932800328013280232803328043280532806328073280832809328103281132812328133281432815328163281732818328193282032821328223282332824328253282632827328283282932830328313283232833328343283532836328373283832839328403284132842328433284432845328463284732848328493285032851328523285332854328553285632857328583285932860328613286232863328643286532866328673286832869328703287132872328733287432875328763287732878328793288032881328823288332884328853288632887328883288932890328913289232893328943289532896328973289832899329003290132902329033290432905329063290732908329093291032911329123291332914329153291632917329183291932920329213292232923329243292532926329273292832929329303293132932329333293432935329363293732938329393294032941329423294332944329453294632947329483294932950329513295232953329543295532956329573295832959329603296132962329633296432965329663296732968329693297032971329723297332974329753297632977329783297932980329813298232983329843298532986329873298832989329903299132992329933299432995329963299732998329993300033001330023300333004330053300633007330083300933010330113301233013330143301533016330173301833019330203302133022330233302433025330263302733028330293303033031330323303333034330353303633037330383303933040330413304233043330443304533046330473304833049330503305133052330533305433055330563305733058330593306033061330623306333064330653306633067330683306933070330713307233073330743307533076330773307833079330803308133082330833308433085330863308733088330893309033091330923309333094330953309633097330983309933100331013310233103331043310533106331073310833109331103311133112331133311433115331163311733118331193312033121331223312333124331253312633127331283312933130331313313233133331343313533136331373313833139331403314133142331433314433145331463314733148331493315033151331523315333154331553315633157331583315933160331613316233163331643316533166331673316833169331703317133172331733317433175331763317733178331793318033181331823318333184331853318633187331883318933190331913319233193331943319533196331973319833199332003320133202332033320433205332063320733208332093321033211332123321333214332153321633217332183321933220332213322233223332243322533226332273322833229332303323133232332333323433235332363323733238332393324033241332423324333244332453324633247332483324933250332513325233253332543325533256332573325833259332603326133262332633326433265332663326733268332693327033271332723327333274332753327633277332783327933280332813328233283332843328533286332873328833289332903329133292332933329433295332963329733298332993330033301333023330333304333053330633307333083330933310333113331233313333143331533316333173331833319333203332133322333233332433325333263332733328333293333033331333323333333334333353333633337333383333933340333413334233343333443334533346333473334833349333503335133352333533335433355333563335733358333593336033361333623336333364333653336633367333683336933370333713337233373333743337533376333773337833379333803338133382333833338433385333863338733388333893339033391333923339333394333953339633397333983339933400334013340233403334043340533406334073340833409334103341133412334133341433415334163341733418334193342033421334223342333424334253342633427334283342933430334313343233433334343343533436334373343833439334403344133442334433344433445334463344733448334493345033451334523345333454334553345633457334583345933460334613346233463334643346533466334673346833469334703347133472334733347433475334763347733478334793348033481334823348333484334853348633487334883348933490334913349233493334943349533496334973349833499335003350133502335033350433505335063350733508335093351033511335123351333514335153351633517335183351933520335213352233523335243352533526335273352833529335303353133532335333353433535335363353733538335393354033541335423354333544335453354633547335483354933550335513355233553335543355533556335573355833559335603356133562335633356433565335663356733568335693357033571335723357333574335753357633577335783357933580335813358233583335843358533586335873358833589335903359133592335933359433595335963359733598335993360033601336023360333604336053360633607336083360933610336113361233613336143361533616336173361833619336203362133622336233362433625336263362733628336293363033631336323363333634336353363633637336383363933640336413364233643336443364533646336473364833649336503365133652336533365433655336563365733658336593366033661336623366333664336653366633667336683366933670336713367233673336743367533676336773367833679336803368133682336833368433685336863368733688336893369033691336923369333694336953369633697336983369933700337013370233703337043370533706337073370833709337103371133712337133371433715337163371733718337193372033721337223372333724337253372633727337283372933730337313373233733337343373533736337373373833739337403374133742337433374433745337463374733748337493375033751337523375333754337553375633757337583375933760337613376233763337643376533766337673376833769337703377133772337733377433775337763377733778337793378033781337823378333784337853378633787337883378933790337913379233793337943379533796337973379833799338003380133802338033380433805338063380733808338093381033811338123381333814338153381633817338183381933820338213382233823338243382533826338273382833829338303383133832338333383433835338363383733838338393384033841338423384333844338453384633847338483384933850338513385233853338543385533856338573385833859338603386133862338633386433865338663386733868338693387033871338723387333874338753387633877338783387933880338813388233883338843388533886338873388833889338903389133892338933389433895338963389733898338993390033901339023390333904339053390633907339083390933910339113391233913339143391533916339173391833919339203392133922339233392433925339263392733928339293393033931339323393333934339353393633937339383393933940339413394233943339443394533946339473394833949339503395133952339533395433955339563395733958339593396033961339623396333964339653396633967339683396933970339713397233973339743397533976339773397833979339803398133982339833398433985339863398733988339893399033991339923399333994339953399633997339983399934000340013400234003340043400534006340073400834009340103401134012340133401434015340163401734018340193402034021340223402334024340253402634027340283402934030340313403234033340343403534036340373403834039340403404134042340433404434045340463404734048340493405034051340523405334054340553405634057340583405934060340613406234063340643406534066340673406834069340703407134072340733407434075340763407734078340793408034081340823408334084340853408634087340883408934090340913409234093340943409534096340973409834099341003410134102341033410434105341063410734108341093411034111341123411334114341153411634117341183411934120341213412234123341243412534126341273412834129341303413134132341333413434135341363413734138341393414034141341423414334144341453414634147341483414934150341513415234153341543415534156341573415834159341603416134162341633416434165341663416734168341693417034171341723417334174341753417634177341783417934180341813418234183341843418534186341873418834189341903419134192341933419434195341963419734198341993420034201342023420334204342053420634207342083420934210342113421234213342143421534216342173421834219342203422134222342233422434225342263422734228342293423034231342323423334234342353423634237342383423934240342413424234243342443424534246342473424834249342503425134252342533425434255342563425734258342593426034261342623426334264342653426634267342683426934270342713427234273342743427534276342773427834279342803428134282342833428434285342863428734288342893429034291342923429334294342953429634297342983429934300343013430234303343043430534306343073430834309343103431134312343133431434315343163431734318343193432034321343223432334324343253432634327343283432934330343313433234333343343433534336343373433834339343403434134342343433434434345343463434734348343493435034351343523435334354343553435634357343583435934360343613436234363343643436534366343673436834369343703437134372343733437434375343763437734378343793438034381343823438334384343853438634387343883438934390343913439234393343943439534396343973439834399344003440134402344033440434405344063440734408344093441034411344123441334414344153441634417344183441934420344213442234423344243442534426344273442834429344303443134432344333443434435344363443734438344393444034441344423444334444344453444634447344483444934450344513445234453344543445534456344573445834459344603446134462344633446434465344663446734468344693447034471344723447334474344753447634477344783447934480344813448234483344843448534486344873448834489344903449134492344933449434495344963449734498344993450034501345023450334504345053450634507345083450934510345113451234513345143451534516345173451834519345203452134522345233452434525345263452734528345293453034531345323453334534345353453634537345383453934540345413454234543345443454534546345473454834549345503455134552345533455434555345563455734558345593456034561345623456334564345653456634567345683456934570345713457234573345743457534576345773457834579345803458134582345833458434585345863458734588345893459034591345923459334594345953459634597345983459934600346013460234603346043460534606346073460834609346103461134612346133461434615346163461734618346193462034621346223462334624346253462634627346283462934630346313463234633346343463534636346373463834639346403464134642346433464434645346463464734648346493465034651346523465334654346553465634657346583465934660346613466234663346643466534666346673466834669346703467134672346733467434675346763467734678346793468034681346823468334684346853468634687346883468934690346913469234693346943469534696346973469834699347003470134702347033470434705347063470734708347093471034711347123471334714347153471634717347183471934720347213472234723347243472534726347273472834729347303473134732347333473434735347363473734738347393474034741347423474334744347453474634747347483474934750347513475234753347543475534756347573475834759347603476134762347633476434765347663476734768347693477034771347723477334774347753477634777347783477934780347813478234783347843478534786347873478834789347903479134792347933479434795347963479734798347993480034801348023480334804348053480634807348083480934810348113481234813348143481534816348173481834819348203482134822348233482434825348263482734828348293483034831348323483334834348353483634837348383483934840348413484234843348443484534846348473484834849348503485134852348533485434855348563485734858348593486034861348623486334864348653486634867348683486934870348713487234873348743487534876348773487834879348803488134882348833488434885348863488734888348893489034891348923489334894348953489634897348983489934900349013490234903349043490534906349073490834909349103491134912349133491434915349163491734918349193492034921349223492334924349253492634927349283492934930349313493234933349343493534936349373493834939349403494134942349433494434945349463494734948349493495034951349523495334954349553495634957349583495934960349613496234963349643496534966349673496834969349703497134972349733497434975349763497734978349793498034981349823498334984349853498634987349883498934990349913499234993349943499534996349973499834999350003500135002350033500435005350063500735008350093501035011350123501335014350153501635017350183501935020350213502235023350243502535026350273502835029350303503135032350333503435035350363503735038350393504035041350423504335044350453504635047350483504935050350513505235053350543505535056350573505835059350603506135062350633506435065350663506735068350693507035071350723507335074350753507635077350783507935080350813508235083350843508535086350873508835089350903509135092350933509435095350963509735098350993510035101351023510335104351053510635107351083510935110351113511235113351143511535116351173511835119351203512135122351233512435125351263512735128351293513035131351323513335134351353513635137351383513935140351413514235143351443514535146351473514835149351503515135152351533515435155351563515735158351593516035161351623516335164351653516635167351683516935170351713517235173351743517535176351773517835179351803518135182351833518435185351863518735188351893519035191351923519335194351953519635197351983519935200352013520235203352043520535206352073520835209352103521135212352133521435215352163521735218352193522035221352223522335224352253522635227352283522935230352313523235233352343523535236352373523835239352403524135242352433524435245352463524735248352493525035251352523525335254352553525635257352583525935260352613526235263352643526535266352673526835269352703527135272352733527435275352763527735278352793528035281352823528335284352853528635287352883528935290352913529235293352943529535296352973529835299353003530135302353033530435305353063530735308353093531035311353123531335314353153531635317353183531935320353213532235323353243532535326353273532835329353303533135332353333533435335353363533735338353393534035341353423534335344353453534635347353483534935350353513535235353353543535535356353573535835359353603536135362353633536435365353663536735368353693537035371353723537335374353753537635377353783537935380353813538235383353843538535386353873538835389353903539135392353933539435395353963539735398353993540035401354023540335404354053540635407354083540935410354113541235413354143541535416354173541835419354203542135422354233542435425354263542735428354293543035431354323543335434354353543635437354383543935440354413544235443354443544535446354473544835449354503545135452354533545435455354563545735458354593546035461354623546335464354653546635467354683546935470354713547235473354743547535476354773547835479354803548135482354833548435485354863548735488354893549035491354923549335494354953549635497354983549935500355013550235503355043550535506355073550835509355103551135512355133551435515355163551735518355193552035521355223552335524355253552635527355283552935530355313553235533355343553535536355373553835539355403554135542355433554435545355463554735548355493555035551355523555335554355553555635557355583555935560355613556235563355643556535566355673556835569355703557135572355733557435575355763557735578355793558035581355823558335584355853558635587355883558935590355913559235593355943559535596355973559835599356003560135602356033560435605356063560735608356093561035611356123561335614356153561635617356183561935620356213562235623356243562535626356273562835629356303563135632356333563435635356363563735638356393564035641356423564335644356453564635647356483564935650356513565235653356543565535656356573565835659356603566135662356633566435665356663566735668356693567035671356723567335674356753567635677356783567935680356813568235683356843568535686356873568835689356903569135692356933569435695356963569735698356993570035701357023570335704357053570635707357083570935710357113571235713357143571535716357173571835719357203572135722357233572435725357263572735728357293573035731357323573335734357353573635737357383573935740357413574235743357443574535746357473574835749357503575135752357533575435755357563575735758357593576035761357623576335764357653576635767357683576935770357713577235773357743577535776357773577835779357803578135782357833578435785357863578735788357893579035791357923579335794357953579635797357983579935800358013580235803358043580535806358073580835809358103581135812358133581435815358163581735818358193582035821358223582335824358253582635827358283582935830358313583235833358343583535836358373583835839358403584135842358433584435845358463584735848358493585035851358523585335854358553585635857358583585935860358613586235863358643586535866358673586835869358703587135872358733587435875358763587735878358793588035881358823588335884358853588635887358883588935890358913589235893358943589535896358973589835899359003590135902359033590435905359063590735908359093591035911359123591335914359153591635917359183591935920359213592235923359243592535926359273592835929359303593135932359333593435935359363593735938359393594035941359423594335944359453594635947359483594935950359513595235953359543595535956359573595835959359603596135962359633596435965359663596735968359693597035971359723597335974359753597635977359783597935980359813598235983359843598535986359873598835989359903599135992359933599435995359963599735998359993600036001360023600336004360053600636007360083600936010360113601236013360143601536016360173601836019360203602136022360233602436025360263602736028360293603036031360323603336034360353603636037360383603936040360413604236043360443604536046360473604836049360503605136052360533605436055360563605736058360593606036061360623606336064360653606636067360683606936070360713607236073360743607536076360773607836079360803608136082360833608436085360863608736088360893609036091360923609336094360953609636097360983609936100361013610236103361043610536106361073610836109361103611136112361133611436115361163611736118361193612036121361223612336124361253612636127361283612936130361313613236133361343613536136361373613836139361403614136142361433614436145361463614736148361493615036151361523615336154361553615636157361583615936160361613616236163361643616536166361673616836169361703617136172361733617436175361763617736178361793618036181361823618336184361853618636187361883618936190361913619236193361943619536196361973619836199362003620136202362033620436205362063620736208362093621036211362123621336214362153621636217362183621936220362213622236223362243622536226362273622836229362303623136232362333623436235362363623736238362393624036241362423624336244362453624636247362483624936250362513625236253362543625536256362573625836259362603626136262362633626436265362663626736268362693627036271362723627336274362753627636277362783627936280362813628236283362843628536286362873628836289362903629136292362933629436295362963629736298362993630036301363023630336304363053630636307363083630936310363113631236313363143631536316363173631836319363203632136322363233632436325363263632736328363293633036331363323633336334363353633636337363383633936340363413634236343363443634536346363473634836349363503635136352363533635436355363563635736358363593636036361363623636336364363653636636367363683636936370363713637236373363743637536376363773637836379363803638136382363833638436385363863638736388363893639036391363923639336394363953639636397363983639936400364013640236403364043640536406364073640836409364103641136412364133641436415364163641736418364193642036421364223642336424364253642636427364283642936430364313643236433364343643536436364373643836439364403644136442364433644436445364463644736448364493645036451364523645336454364553645636457364583645936460364613646236463364643646536466364673646836469364703647136472364733647436475364763647736478364793648036481364823648336484364853648636487364883648936490364913649236493364943649536496364973649836499365003650136502365033650436505365063650736508365093651036511365123651336514365153651636517365183651936520365213652236523365243652536526365273652836529365303653136532365333653436535365363653736538365393654036541365423654336544365453654636547365483654936550365513655236553365543655536556365573655836559365603656136562365633656436565365663656736568365693657036571365723657336574365753657636577365783657936580365813658236583365843658536586365873658836589365903659136592365933659436595365963659736598365993660036601366023660336604366053660636607366083660936610366113661236613366143661536616366173661836619366203662136622366233662436625366263662736628366293663036631366323663336634366353663636637366383663936640366413664236643366443664536646366473664836649366503665136652366533665436655366563665736658366593666036661366623666336664366653666636667366683666936670366713667236673366743667536676366773667836679366803668136682366833668436685366863668736688366893669036691366923669336694366953669636697366983669936700367013670236703367043670536706367073670836709367103671136712367133671436715367163671736718367193672036721367223672336724367253672636727367283672936730367313673236733367343673536736367373673836739367403674136742367433674436745367463674736748367493675036751367523675336754367553675636757367583675936760367613676236763367643676536766367673676836769367703677136772367733677436775367763677736778367793678036781367823678336784367853678636787367883678936790367913679236793367943679536796367973679836799368003680136802368033680436805368063680736808368093681036811368123681336814368153681636817368183681936820368213682236823368243682536826368273682836829368303683136832368333683436835368363683736838368393684036841368423684336844368453684636847368483684936850368513685236853368543685536856368573685836859368603686136862368633686436865368663686736868368693687036871368723687336874368753687636877368783687936880368813688236883368843688536886368873688836889368903689136892368933689436895368963689736898368993690036901369023690336904369053690636907369083690936910369113691236913369143691536916369173691836919369203692136922369233692436925369263692736928369293693036931369323693336934369353693636937369383693936940369413694236943369443694536946369473694836949369503695136952369533695436955369563695736958369593696036961369623696336964369653696636967369683696936970369713697236973369743697536976369773697836979369803698136982369833698436985369863698736988369893699036991369923699336994369953699636997369983699937000370013700237003370043700537006370073700837009370103701137012370133701437015370163701737018370193702037021370223702337024370253702637027 |
- {
- 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;
- // ToDo: insert(record,ArrayOfRecord,0)
- // 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_AssignVar;
- Procedure TestClassInterface_COM_ArrayOfIntf_AssignPlus;
- Procedure TestClassInterface_COM_ArrayOfIntf_AssignArg;
- Procedure TestClassInterface_COM_ArrayOfIntf_InitFail;
- Procedure TestClassInterface_COM_ArrayOfIntf_FunctionResult;
- Procedure TestClassInterface_COM_ArrayOfIntf_InheritedFuncResult;
- Procedure TestClassInterface_COM_ArrayOfIntf_FunctionExit;
- Procedure TestClassInterface_COM_ArrayOfIntf_Property;
- Procedure TestClassInterface_COM_ArrayOfIntf_BIFuncs;
- Procedure TestClassInterface_COM_ArrayOfIntf_ForIn;
- Procedure TestClassInterface_COM_StaticArrayOfIntfFail;
- 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_CallFuncResultIsPromise;
- Procedure TestAsync_CallProcResultIsPromise;
- 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_ProcTypeDelphi_NoTJSPromise;
- Procedure TestAsync_ProcTypeDelphi_TJSPromise;
- 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+'['+IntToStr(E.Id)+']:'
- +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", {}, this);',
- ' $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);',
- ' rtl._AddRef(j);',
- ' try {',
- ' i = rtl.setIntfL(i, null);',
- ' i = rtl.setIntfL(i, j);',
- ' } finally {',
- ' rtl._Release(i);',
- ' rtl._Release(j);',
- ' };',
- '};',
- '']),
- 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;',
- 'var i: IUnknown;',
- 'begin',
- ' DoDefault(i);',
- ' i:=DoDefault(i);',
- '']);
- 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;',
- ' rtl._AddRef(i);',
- ' var $ok = false;',
- ' try {',
- ' Result = rtl.setIntfL(Result, i);',
- ' if(Result !== null){',
- ' $ok = true;',
- ' return Result;',
- ' };',
- ' $ok = true;',
- ' } finally {',
- ' rtl._Release(i);',
- ' if(!$ok) rtl._Release(Result);',
- ' };',
- ' return Result;',
- '};',
- 'this.i = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'var $ir = rtl.createIntfRefs();',
- 'try {',
- ' $ir.ref(1, $mod.DoDefault($mod.i));',
- ' rtl.setIntfP($mod, "i", $mod.DoDefault($mod.i), true);',
- '} finally {',
- ' $ir.free();',
- '};',
- '']));
- 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);',
- ' rtl._AddRef(j);',
- ' 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);',
- ' rtl._Release(j);',
- ' };',
- '};',
- '']),
- 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_AssignVar;
- begin
- 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: TBirdArray;',
- ' b: TBirdArray = nil;',
- 'begin',
- ' a:=nil;',
- ' a:=[];',
- ' SetLength(a,3);',
- ' b:=a;',
- ' i:=a[1];',
- ' a[2]:=i;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf_AssignVar',
- 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 = null;',
- ' var b = null;',
- ' try {',
- ' a = rtl.setIntfL(a, null);',
- ' a = rtl.setIntfL(a, null);',
- ' a = rtl.arraySetLength(a, "R", 3);',
- ' b = rtl.setIntfL(b, a);',
- ' i = rtl.setIntfL(i, a[1]);',
- ' rtl.setIntfP(a, 2, i);',
- ' } finally {',
- ' rtl._Release(a);',
- ' rtl._Release(b);',
- ' rtl._Release(i);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf_AssignPlus;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- '{$modeswitch ArrayOperators}',
- 'type',
- ' IUnknown = interface end;',
- ' IBird = interface(IUnknown)',
- ' function Fly(w: word): word;',
- ' end;',
- ' TBirdArray = array of IBird;',
- 'procedure Run;',
- 'var',
- ' i: IBird;',
- ' a: TBirdArray;',
- ' b: TBirdArray = nil;',
- 'begin',
- ' a:=a+b;',
- ' a:=[i,i];',
- ' a:=a+[i];',
- ' a:=b+[i];',
- ' a:=[i]+a;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf_AssignPlus',
- 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 = null;',
- ' var b = null;',
- ' var $ir = rtl.createIntfRefs();',
- ' try {',
- ' a = rtl.setIntfL(a, rtl.arrayConcat("R", a, b), true);',
- ' a = rtl.setIntfL(a, rtl.arrayManaged(1, 2, [i, i]), true);',
- ' a = rtl.setIntfL(a, rtl.arrayPush("R", a, i), true);',
- ' a = rtl.setIntfL(a, rtl.arrayConcat("R", b, $ir.ref(1, rtl.arrayManaged(1, 2, [i]))), true);',
- ' a = rtl.setIntfL(a, rtl.arrayConcat("R", $ir.ref(2, rtl.arrayManaged(1, 2, [i])), a), true);',
- ' } finally {',
- ' $ir.free();',
- ' rtl._Release(a);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf_AssignArg;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface end;',
- ' IBird = interface(IUnknown)',
- ' function Fly(w: word): word;',
- ' end;',
- ' TBirdArray = array of IBird;',
- 'procedure ArgDefault(a: TBirdArray);',
- 'var b: TBirdArray;',
- 'begin',
- ' b:=a;',
- 'end;',
- 'procedure ArgConst(const a: TBirdArray);',
- 'begin',
- 'end;',
- 'procedure ArgVar(var a: TBirdArray);',
- 'begin',
- ' a:=nil;',
- 'end;',
- 'procedure ArgOut(out a: TBirdArray);',
- 'begin',
- 'end;',
- 'procedure Run;',
- 'var',
- ' i: IBird;',
- ' a: TBirdArray;',
- 'begin',
- ' ArgDefault(a);',
- ' ArgDefault(nil);',
- ' ArgDefault([i]);',
- ' ArgConst(a);',
- ' ArgConst([i]);',
- ' ArgVar(a);',
- ' ArgOut(a);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf_AssignArg',
- 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.ArgDefault = function (a) {',
- ' var b = null;',
- ' rtl._AddRef(a);',
- ' try {',
- ' b = rtl.setIntfL(b, a);',
- ' } finally {',
- ' rtl._Release(a);',
- ' rtl._Release(b);',
- ' };',
- '};',
- 'this.ArgConst = function (a) {',
- '};',
- 'this.ArgVar = function (a) {',
- ' a.set(null);',
- '};',
- 'this.ArgOut = function (a) {',
- '};',
- 'this.Run = function () {',
- ' var i = null;',
- ' var a = null;',
- ' var $ir = rtl.createIntfRefs();',
- ' try {',
- ' $mod.ArgDefault(a);',
- ' $mod.ArgDefault(null);',
- ' $mod.ArgDefault($ir.ref(1, rtl.arrayManaged(1, 2, [i])));',
- ' $mod.ArgConst(a);',
- ' $mod.ArgConst($ir.ref(2, rtl.arrayManaged(1, 2, [i])));',
- ' $mod.ArgVar({',
- ' get: function () {',
- ' return a;',
- ' },',
- ' set: function (v) {',
- ' a = rtl.setIntfL(a, v);',
- ' }',
- ' });',
- ' $mod.ArgOut({',
- ' get: function () {',
- ' return a;',
- ' },',
- ' set: function (v) {',
- ' a = rtl.setIntfL(a, v);',
- ' }',
- ' });',
- ' } finally {',
- ' $ir.free();',
- ' rtl._Release(a);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf_InitFail;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TBirdArray = array of IUnknown;',
- 'var',
- ' i: IUnknown;',
- ' a: TBirdArray = (i);',
- 'begin',
- '']);
- SetExpectedPasResolverError('Not supported: initial value of managed type',nNotSupportedX);
- ConvertProgram;
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf_FunctionResult;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class end;',
- ' TBird = array of IUnknown;',
- 'function DoDefault(i: TBird): TBird;',
- 'begin',
- ' Result:=i;',
- ' if Result<>nil then exit;',
- 'end;',
- 'var b: TBird;',
- 'begin',
- ' DoDefault(b);',
- ' b:=DoDefault(b);',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf_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 () {',
- ' };',
- '});',
- 'this.DoDefault = function (i) {',
- ' var Result = null;',
- ' rtl._AddRef(i);',
- ' var $ok = false;',
- ' try {',
- ' Result = rtl.setIntfL(Result, i);',
- ' if (rtl.length(Result) > 0) {',
- ' $ok = true;',
- ' return Result;',
- ' };',
- ' $ok = true;',
- ' } finally {',
- ' rtl._Release(i);',
- ' if(!$ok) rtl._Release(Result);',
- ' };',
- ' return Result;',
- '};',
- 'this.b = null;',
- '']),
- LinesToStr([ // $mod.$main
- 'var $ir = rtl.createIntfRefs();',
- 'try {',
- ' $ir.ref(1, $mod.DoDefault($mod.b));',
- ' rtl.setIntfP($mod, "b", $mod.DoDefault($mod.b), true);',
- '} finally {',
- ' $ir.free();',
- '};',
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf_InheritedFuncResult;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TBird = array of IUnknown;',
- ' TObject = class',
- ' function GetIntf: TBird; virtual;',
- ' end;',
- ' TMouse = class',
- ' function GetIntf: TBird; override;',
- ' end;',
- 'function TObject.GetIntf: TBird; begin end;',
- 'function TMouse.GetIntf: TBird;',
- 'var i: TBird;',
- 'begin',
- ' inherited;',
- ' inherited GetIntf;',
- ' inherited GetIntf();',
- ' Result:=inherited GetIntf;',
- ' Result:=inherited GetIntf();',
- ' i:=inherited GetIntf;',
- ' i:=inherited GetIntf();',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf_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.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;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf_FunctionExit;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TBird = array of IUnknown;',
- ' TObject = class',
- ' constructor Create;',
- ' end;',
- 'constructor TObject.Create;',
- 'begin',
- 'end;',
- 'function GetIntf: TBird;',
- 'var b: TBird;',
- 'begin',
- ' b:=[];',
- ' Exit(b);',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf_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;',
- ' };',
- '});',
- 'this.GetIntf = function () {',
- ' var Result = null;',
- ' var b = null;',
- ' var $ok = false;',
- ' try {',
- ' b = rtl.setIntfL(b, null);',
- ' $ok = true;',
- ' Result = rtl.setIntfL(Result, b);',
- ' return Result;',
- ' $ok = true;',
- ' } finally {',
- ' rtl._Release(b);',
- ' if (!$ok) rtl._Release(Result);',
- ' };',
- ' return Result;',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf_Property;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TAnimal = array of IUnknown;',
- ' TObject = class',
- ' FAnt: TAnimal;',
- ' function GetBird: TAnimal; virtual; abstract;',
- ' procedure SetBird(Value: TAnimal); virtual; abstract;',
- ' function GetItems(Index: longint): TAnimal; virtual; abstract;',
- ' procedure SetItems(Index: longint; Value: TAnimal); virtual; abstract;',
- ' property Ant: TAnimal read FAnt write FAnt;',
- ' property Bird: TAnimal read GetBird write SetBird;',
- ' property Items[Index: longint]: TAnimal read GetItems write SetItems; default;',
- ' end;',
- 'procedure DoIt;',
- 'var',
- ' o: TObject;',
- ' v: TAnimal;',
- '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_ArrayOfIntf_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);',
- ' };',
- '});',
- '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_ArrayOfIntf_BIFuncs;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface end;',
- ' IBird = interface(IUnknown)',
- ' end;',
- ' TBirdArray = array of IBird;',
- 'procedure Run;',
- 'var',
- ' i: IBird;',
- ' a, b: TBirdArray;',
- 'begin',
- ' SetLength(a,3);',
- ' a:=copy(b,1,2);',
- ' a:=concat(b);',
- ' a:=concat(b,a);',
- ' insert(i,b,1);',
- ' delete(a,1,2);', // array,index,count
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf_BIFuncs',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], this.IUnknown);',
- 'this.Run = function () {',
- ' var i = null;',
- ' var a = null;',
- ' var b = null;',
- ' try {',
- ' a = rtl.arraySetLength(a, "R", 3);',
- ' a = rtl.setIntfL(a, rtl.arrayCopy("R", b, 1, 2), true);',
- ' a = rtl.setIntfL(a, b);',
- ' a = rtl.setIntfL(a, rtl.arrayConcat("R", b, a), true);',
- ' b = rtl.arrayInsert(i, b, 1, "R");',
- ' a = rtl.arrayDeleteR(a, 1, 2);',
- ' } finally {',
- ' rtl._Release(a);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_ArrayOfIntf_ForIn;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface end;',
- ' IBird = interface(IUnknown)',
- ' end;',
- ' TBirdArray = array of IBird;',
- 'procedure Run;',
- 'var',
- ' i, j: IBird;',
- ' a: TBirdArray;',
- 'begin',
- ' for i in a do begin',
- ' j:=i;',
- ' end;',
- 'end;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_COM_ArrayOfIntf_ForIn',
- LinesToStr([ // statements
- 'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
- 'rtl.createInterface(this, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], this.IUnknown);',
- 'this.Run = function () {',
- ' var i = null;',
- ' var j = null;',
- ' var a = null;',
- ' try {',
- ' for (var $in = a, $l = 0, $end = rtl.length($in) - 1; $l <= $end; $l++) {',
- ' i = rtl.setIntfL(i, $in[$l]);',
- ' j = rtl.setIntfL(j, i);',
- ' };',
- ' } finally {',
- ' rtl._Release(i);',
- ' rtl._Release(j);',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClassInterface_COM_StaticArrayOfIntfFail;
- begin
- StartProgram(false);
- Add([
- '{$interfaces com}',
- 'type',
- ' IUnknown = interface',
- ' function _AddRef: longint;',
- ' function _Release: longint;',
- ' end;',
- ' TObject = class',
- ' end;',
- ' TArrOfIntf = array[0..1] of IUnknown;',
- 'begin',
- '']);
- SetExpectedPasResolverError('Not supported: static 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, [], 3, 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",',
- ' "",',
- ' 3',
- ' );',
- '});',
- '']),
- 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", {}, this);',
- ' $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", {}, this);',
- ' $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", {}, this);',
- ' $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, [], 2, 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]], 2, rtl.longint);',
- ' $r.addMethod("_AddRef", 1, [], 2, rtl.longint);',
- ' $r.addMethod("_Release", 1, [], 2, rtl.longint);',
- ' }',
- ');',
- 'rtl.createInterface(',
- ' this,',
- ' "IBird",',
- ' "{9CC77572-0E45-3594-9A88-9E8D865C9E0A}",',
- ' ["GetItem", "SetItem"],',
- ' this.IUnknown,',
- ' function () {',
- ' var $r = this.$rtti;',
- ' $r.addMethod("GetItem", 1, [], 2, 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_Unit',
- 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, [], 2, pas.unit2.$rtti["TWordArray"]);',
- ' $r.addMethod("Glide", 1, [], 2, 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", {}, this);',
- ' $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_CallFuncResultIsPromise;
- 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_CallFuncResultIsPromise',
- 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_CallProcResultIsPromise;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TObject = class',
- ' end;',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' TBird = class',
- ' procedure Fly; async; ',
- ' end;',
- 'procedure TBird.Fly; async; ',
- 'begin',
- 'end;',
- 'procedure Run; async;',
- 'begin',
- '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_CallProcResultIsPromise',
- 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 () {',
- ' };',
- '});',
- 'this.Run = async function () {',
- '};',
- '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 can 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_ProcTypeDelphi_NoTJSPromise;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- 'type',
- ' TRefProc = reference to procedure; async;',
- 'procedure Run(p: TRefProc);',
- 'begin',
- 'end;',
- 'procedure Fly; async;',
- 'begin',
- 'end;',
- 'begin',
- ' Run(Fly);',
- ' ']);
- ConvertProgram;
- end;
- procedure TTestModule.TestAsync_ProcTypeDelphi_TJSPromise;
- begin
- StartProgram(false);
- Add([
- '{$mode delphi}',
- '{$modeswitch externalclass}',
- 'type',
- ' TJSPromise = class external name ''Promise''',
- ' end;',
- ' TRefProc = reference to procedure; async;',
- 'procedure Run(p: TRefProc);',
- 'begin',
- 'end;',
- 'procedure Fly; async;',
- 'begin',
- 'end;',
- 'begin',
- ' Run(Fly);',
- ' ']);
- 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.
|
