12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734147351473614737147381473914740147411474214743147441474514746147471474814749147501475114752147531475414755147561475714758147591476014761147621476314764147651476614767147681476914770147711477214773147741477514776147771477814779147801478114782147831478414785147861478714788147891479014791147921479314794147951479614797147981479914800148011480214803148041480514806148071480814809148101481114812148131481414815148161481714818148191482014821148221482314824148251482614827148281482914830148311483214833148341483514836148371483814839148401484114842148431484414845148461484714848148491485014851148521485314854148551485614857148581485914860148611486214863148641486514866148671486814869148701487114872148731487414875148761487714878148791488014881148821488314884148851488614887148881488914890148911489214893148941489514896148971489814899149001490114902149031490414905149061490714908149091491014911149121491314914149151491614917149181491914920149211492214923149241492514926149271492814929149301493114932149331493414935149361493714938149391494014941149421494314944149451494614947149481494914950149511495214953149541495514956149571495814959149601496114962149631496414965149661496714968149691497014971149721497314974149751497614977149781497914980149811498214983149841498514986149871498814989149901499114992149931499414995149961499714998149991500015001150021500315004150051500615007150081500915010150111501215013150141501515016150171501815019150201502115022150231502415025150261502715028150291503015031150321503315034150351503615037150381503915040150411504215043150441504515046150471504815049150501505115052150531505415055150561505715058150591506015061150621506315064150651506615067150681506915070150711507215073150741507515076150771507815079150801508115082150831508415085150861508715088150891509015091150921509315094150951509615097150981509915100151011510215103151041510515106151071510815109151101511115112151131511415115151161511715118151191512015121151221512315124151251512615127151281512915130151311513215133151341513515136151371513815139151401514115142151431514415145151461514715148151491515015151151521515315154151551515615157151581515915160151611516215163151641516515166151671516815169151701517115172151731517415175151761517715178151791518015181151821518315184151851518615187151881518915190151911519215193151941519515196151971519815199152001520115202152031520415205152061520715208152091521015211152121521315214152151521615217152181521915220152211522215223152241522515226152271522815229152301523115232152331523415235152361523715238152391524015241152421524315244152451524615247152481524915250152511525215253152541525515256152571525815259152601526115262152631526415265152661526715268152691527015271152721527315274152751527615277152781527915280152811528215283152841528515286152871528815289152901529115292152931529415295152961529715298152991530015301153021530315304153051530615307153081530915310153111531215313153141531515316153171531815319153201532115322153231532415325153261532715328153291533015331153321533315334153351533615337153381533915340153411534215343153441534515346153471534815349153501535115352153531535415355153561535715358153591536015361153621536315364153651536615367153681536915370153711537215373153741537515376153771537815379153801538115382 |
- {
- This file is part of the Free Component Library (FCL)
- Copyright (c) 2014 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_pas2js = [po_asmwhole,po_resolvestandardtypes];
- co_tcmodules = [coNoTypeInfo];
- type
- { 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;
- FResolver: TStreamResolver;
- FScanner: TPascalScanner;
- FSource: string;
- procedure SetModule(AValue: TPasModule);
- public
- destructor Destroy; override;
- function FindModule(const AName: String): TPasModule; override;
- property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
- property Filename: string read FFilename write FFilename;
- property Resolver: TStreamResolver read FResolver write FResolver;
- property Scanner: TPascalScanner 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
- FConverter: TPasToJSConverter;
- FEngine: TTestEnginePasResolver;
- FExpectedErrorClass: ExceptClass;
- FExpectedErrorMsg: string;
- FExpectedErrorNumber: integer;
- FFilename: string;
- FFileResolver: TStreamResolver;
- FJSImplementationSrc: TJSSourceElements;
- FJSImplementationUses: TJSArrayLiteral;
- FJSInitBody: TJSFunctionBody;
- FJSImplentationUses: TJSArrayLiteral;
- FJSInterfaceUses: TJSArrayLiteral;
- FJSModule: TJSSourceElements;
- FJSModuleSrc: TJSSourceElements;
- FJSSource: TStringList;
- FModule: TPasModule;
- FJSModuleCallArgs: TJSArguments;
- FModules: TObjectList;// list of TTestEnginePasResolver
- FParser: TTestPasParser;
- FPasProgram: TPasProgram;
- FJSRegModuleCall: TJSCallExpression;
- FScanner: TPascalScanner;
- FSkipTests: boolean;
- FSource: TStringList;
- FFirstPasStatement: TPasImplBlock;
- function GetResolverCount: integer;
- function GetResolvers(Index: integer): TTestEnginePasResolver;
- function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
- function FindUnit(const aUnitName: String): TPasModule;
- protected
- procedure SetUp; override;
- function CreateConverter: TPasToJSConverter; virtual;
- procedure TearDown; override;
- Procedure Add(Line: string); virtual;
- Procedure Add(const Lines: array of string);
- Procedure StartParsing; virtual;
- procedure ParseModule; virtual;
- procedure ParseProgram; virtual;
- procedure ParseUnit; virtual;
- protected
- function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual;
- function AddModule(aFilename: string): TTestEnginePasResolver; virtual;
- function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual;
- function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
- ImplementationSrc: string): TTestEnginePasResolver; virtual;
- procedure AddSystemUnit; virtual;
- procedure StartProgram(NeedSystemUnit: boolean); virtual;
- procedure StartUnit(NeedSystemUnit: boolean); virtual;
- procedure ConvertModule; virtual;
- procedure ConvertProgram; virtual;
- procedure ConvertUnit; virtual;
- function ConvertJSModuleToString(El: TJSElement): string; virtual;
- procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
- function GetDottedIdentifier(El: TJSElement): string;
- procedure CheckSource(Msg,Statements: String; InitStatements: string = '';
- ImplStatements: string = ''); virtual;
- procedure CheckDiff(Msg, Expected, Actual: string); virtual;
- procedure CheckUnit(Filename, ExpectedSrc: string); virtual;
- procedure SetExpectedScannerError(Msg: string; MsgNumber: integer);
- procedure SetExpectedParserError(Msg: string; MsgNumber: integer);
- procedure SetExpectedPasResolverError(Msg: string; MsgNumber: integer);
- procedure SetExpectedConverterError(Msg: string; MsgNumber: integer);
- function IsErrorExpected(E: Exception): boolean;
- procedure HandleScannerError(E: EScannerError);
- procedure HandleParserError(E: EParserError);
- procedure HandlePasResolveError(E: EPasResolve);
- procedure HandlePas2JSError(E: EPas2JS);
- procedure HandleException(E: Exception);
- procedure RaiseException(E: Exception);
- procedure WriteSources(const aFilename: string; aRow, aCol: integer);
- function IndexOfResolver(const Filename: string): integer;
- function GetResolver(const Filename: string): TTestEnginePasResolver;
- function GetDefaultNamespace: string;
- property PasProgram: TPasProgram Read FPasProgram;
- property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
- property ResolverCount: integer read GetResolverCount;
- property Engine: TTestEnginePasResolver read FEngine;
- property Filename: string read FFilename;
- Property Module: TPasModule Read FModule;
- property FirstPasStatement: TPasImplBlock read FFirstPasStatement;
- property Converter: TPasToJSConverter read FConverter;
- property JSSource: TStringList read FJSSource;
- property JSModule: TJSSourceElements read FJSModule;
- property JSRegModuleCall: TJSCallExpression read FJSRegModuleCall;
- property JSModuleCallArgs: TJSArguments read FJSModuleCallArgs;
- property JSImplementationUses: TJSArrayLiteral read FJSImplementationUses;
- property JSInterfaceUses: TJSArrayLiteral read FJSInterfaceUses;
- property JSModuleSrc: TJSSourceElements read FJSModuleSrc;
- property JSInitBody: TJSFunctionBody read FJSInitBody;
- property JSImplementationSrc: TJSSourceElements read FJSImplementationSrc;
- 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
- property Source: TStringList read FSource;
- property FileResolver: TStreamResolver read FFileResolver;
- property Scanner: TPascalScanner read FScanner;
- property Parser: TTestPasParser read FParser;
- end;
- { TTestModule }
- TTestModule = class(TCustomTestModule)
- Published
- // Resolvers
- Procedure TestEmptyProgram;
- Procedure TestEmptyProgramUseStrict;
- Procedure TestEmptyUnit;
- Procedure TestEmptyUnitUseStrict;
- Procedure TestDottedUnitNames;
- Procedure TestDottedUnitNameImpl;
- Procedure TestDottedUnitExpr;
- Procedure Test_ModeFPCFail;
- Procedure Test_ModeSwitchCBlocksFail;
- // 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;
- // numbers
- Procedure TestDouble;
- Procedure TestIntegerRange;
- Procedure TestForBoolDo;
- // strings
- Procedure TestCharConst;
- Procedure TestChar_Compare;
- Procedure TestChar_Ord;
- Procedure TestChar_Chr;
- Procedure TestStringConst;
- Procedure TestString_Length;
- Procedure TestString_Compare;
- Procedure TestString_SetLength;
- Procedure TestString_CharAt;
- Procedure TestStr;
- Procedure TestBaseType_AnsiStringFail;
- Procedure TestBaseType_WideStringFail;
- Procedure TestBaseType_ShortStringFail;
- Procedure TestBaseType_RawByteStringFail;
- Procedure TestTypeShortstring_Fail;
- Procedure TestCharSet_Custom;
- 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 TestForwardProc;
- Procedure TestNestedForwardProc;
- Procedure TestAssignFunctionResult;
- Procedure TestFunctionResultInCondition;
- Procedure TestExit;
- Procedure TestBreak;
- Procedure TestContinue;
- Procedure TestProc_External;
- Procedure TestProc_ExternalOtherUnit;
- Procedure TestProc_Asm;
- Procedure TestProc_Assembler;
- Procedure TestProc_VarParam;
- Procedure TestProc_Overload;
- Procedure TestProc_OverloadForward;
- Procedure TestProc_OverloadUnit;
- Procedure TestProc_OverloadNested;
- Procedure TestProc_Varargs;
- Procedure TestProc_ConstOrder;
- // enums, sets
- Procedure TestEnum_Name;
- Procedure TestEnum_Number;
- Procedure TestEnum_Functions;
- Procedure TestEnum_AsParams;
- Procedure TestEnumRange_Array;
- Procedure TestSet;
- Procedure TestSet_Operators;
- Procedure TestSet_Operator_In;
- Procedure TestSet_Functions;
- Procedure TestSet_PassAsArgClone;
- Procedure TestSet_AsParams;
- Procedure TestSet_Property;
- Procedure TestSet_EnumConst;
- Procedure TestSet_AnonymousEnumType;
- Procedure TestSet_ConstEnum;
- Procedure TestSet_ConstChar;
- Procedure TestSet_ConstInt;
- // statements
- Procedure TestNestBegin;
- Procedure TestIncDec;
- Procedure TestAssignments;
- Procedure TestArithmeticOperators1;
- Procedure TestLogicalOperators;
- Procedure TestBitwiseOperators;
- Procedure TestFunctionInt;
- Procedure TestFunctionString;
- Procedure TestForLoop;
- Procedure TestForLoopInFunction;
- Procedure TestForLoop_ReadVarAfter;
- Procedure TestForLoop_Nested;
- Procedure TestRepeatUntil;
- Procedure TestAsmBlock;
- Procedure TestAsmPas_Impl; // ToDo
- Procedure TestTryFinally;
- Procedure TestTryExcept;
- Procedure TestCaseOf;
- Procedure TestCaseOf_UseSwitch;
- Procedure TestCaseOfNoElse;
- Procedure TestCaseOfNoElse_UseSwitch;
- Procedure TestCaseOfRange;
- // arrays
- Procedure TestArray_Dynamic;
- Procedure TestArray_Dynamic_Nil;
- Procedure TestArray_DynMultiDimensional;
- Procedure TestArray_StaticInt;
- Procedure TestArray_StaticBool;
- Procedure TestArray_StaticChar;
- Procedure TestArray_StaticMultiDim; // ToDo
- Procedure TestArrayOfRecord;
- // ToDo: Procedure TestArrayOfSet;
- Procedure TestArray_AsParams;
- Procedure TestArrayElement_AsParams;
- Procedure TestArrayElementFromFuncResult_AsParams;
- Procedure TestArrayEnumTypeRange;
- Procedure TestArray_SetLengthOutArg;
- Procedure TestArray_SetLengthProperty;
- Procedure TestArray_SetLengthMultiDim;
- Procedure TestArray_OpenArrayOfString;
- Procedure TestArray_Concat;
- Procedure TestArray_Copy;
- Procedure TestArray_InsertDelete;
- Procedure TestArray_DynArrayConst;
- Procedure TestExternalClass_TypeCastArrayToExternalArray;
- Procedure TestExternalClass_TypeCastArrayFromExternalArray;
- // record
- Procedure TestRecord_Var;
- Procedure TestWithRecordDo;
- Procedure TestRecord_Assign;
- Procedure TestRecord_PassAsArgClone;
- Procedure TestRecord_AsParams;
- Procedure TestRecordElement_AsParams;
- Procedure TestRecordElementFromFuncResult_AsParams;
- Procedure TestRecordElementFromWith_AsParams;
- Procedure TestRecord_Equal;
- Procedure TestRecord_TypeCastJSValueToRecord;
- // ToDo: const record
- // classes
- Procedure TestClass_TObjectDefaultConstructor;
- Procedure TestClass_TObjectConstructorWithParams;
- Procedure TestClass_TObjectConstructorWithDefaultParam;
- Procedure TestClass_Var;
- Procedure TestClass_Method;
- Procedure TestClass_Implementation;
- Procedure TestClass_Inheritance;
- Procedure TestClass_AbstractMethod;
- Procedure TestClass_CallInherited_NoParams;
- Procedure TestClass_CallInherited_WithParams;
- Procedure TestClasS_CallInheritedConstructor;
- Procedure TestClass_ClassVar;
- Procedure TestClass_CallClassMethod;
- Procedure TestClass_Property;
- Procedure TestClass_Property_ClassMethod;
- Procedure TestClass_Property_Indexed;
- Procedure TestClass_Property_IndexSpec;
- Procedure TestClass_PropertyOfTypeArray;
- Procedure TestClass_PropertyDefault;
- Procedure TestClass_PropertyOverride;
- 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_ReintroducedVar;
- Procedure TestClass_RaiseDescendant;
- Procedure TestClass_ExternalMethod;
- Procedure TestClass_ExternalVirtualNameMismatchFail;
- Procedure TestClass_ExternalOverrideFail;
- Procedure TestClass_ExternalVar;
- Procedure TestClass_Const;
- Procedure TestClass_LocalVarSelfFail;
- Procedure TestClass_ArgSelfFail;
- Procedure TestClass_NestedSelf;
- Procedure TestClass_NestedClassSelf;
- Procedure TestClass_NestedCallInherited;
- Procedure TestClass_TObjectFree;
- Procedure TestClass_TObjectFreeNewInstance;
- Procedure TestClass_TObjectFreeLowerCase;
- Procedure TestClass_TObjectFreeFunctionFail;
- Procedure TestClass_TObjectFreePropertyFail;
- // 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_Fail;
- // external class
- Procedure TestExternalClass_Var;
- //ToDo Procedure TestExternalClass_Const;
- Procedure TestExternalClass_Dollar;
- Procedure TestExternalClass_DuplicateVarFail;
- Procedure TestExternalClass_Method;
- Procedure TestExternalClass_NonExternalOverride;
- Procedure TestExternalClass_Property;
- 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_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_PascalProperty;
- Procedure TestExternalClass_TypeCastToRootClass;
- Procedure TestExternalClass_TypeCastStringToExternalString;
- Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
- Procedure TestExternalClass_BracketAccessor;
- Procedure TestExternalClass_BracketAccessor_2ParamsFail;
- Procedure TestExternalClass_BracketAccessor_ReadOnly;
- Procedure TestExternalClass_BracketAccessor_WriteOnly;
- Procedure TestExternalClass_BracketAccessor_MultiType;
- Procedure TestExternalClass_BracketAccessor_Index;
- // class interfaces
- Procedure TestClassInterface_Ignore;
- // proc types
- Procedure TestProcType;
- 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;
- // pointer
- Procedure TestPointer;
- Procedure TestPointer_Proc;
- Procedure TestPointer_AssignRecordFail;
- Procedure TestPointer_AssignStaticArrayFail;
- Procedure TestPointer_ArrayParamsFail;
- Procedure TestPointer_TypeCastJSValueToPointer;
- // jsvalue
- Procedure TestJSValue_AssignToJSValue;
- Procedure TestJSValue_TypeCastToBaseType;
- Procedure TestJSValue_Equal;
- Procedure TestJSValue_If;
- Procedure TestJSValue_Enum;
- Procedure TestJSValue_ClassInstance;
- Procedure TestJSValue_ClassOf;
- Procedure TestJSValue_ArrayOfJSValue;
- Procedure TestJSValue_Params;
- Procedure TestJSValue_UntypedParam;
- Procedure TestJSValue_FuncResultType;
- Procedure TestJSValue_ProcType_Assign;
- Procedure TestJSValue_ProcType_Equal;
- Procedure TestJSValue_AssignToPointerFail;
- Procedure TestJSValue_OverloadDouble;
- Procedure TestJSValue_OverloadNativeInt;
- Procedure TestJSValue_OverloadWord;
- Procedure TestJSValue_OverloadString;
- Procedure TestJSValue_OverloadChar;
- Procedure TestJSValue_OverloadPointer;
- // RTTI
- Procedure TestRTTI_ProcType;
- Procedure TestRTTI_ProcType_ArgFromOtherUnit;
- Procedure TestRTTI_EnumAndSetType;
- Procedure TestRTTI_EnumRange;
- Procedure TestRTTI_AnonymousEnumType;
- Procedure TestRTTI_StaticArray;
- Procedure TestRTTI_DynArray;
- Procedure TestRTTI_ArrayNestedAnonymous;
- // ToDo: Procedure TestRTTI_Pointer;
- Procedure TestRTTI_PublishedMethodOverloadFail;
- Procedure TestRTTI_PublishedMethodExternalFail;
- Procedure TestRTTI_PublishedClassPropertyFail;
- Procedure TestRTTI_PublishedClassFieldFail;
- Procedure TestRTTI_PublishedFieldExternalFail;
- Procedure TestRTTI_IndexModifier;
- Procedure TestRTTI_StoredModifier;
- Procedure TestRTTI_DefaultValue;
- Procedure TestRTTI_DefaultValueSet;
- Procedure TestRTTI_DefaultValueRangeType;
- Procedure TestRTTI_Class_Field;
- Procedure TestRTTI_Class_Method;
- Procedure TestRTTI_Class_MethodArgFlags;
- Procedure TestRTTI_Class_Property;
- Procedure TestRTTI_Class_PropertyParams;
- Procedure TestRTTI_OverrideMethod;
- Procedure TestRTTI_OverloadProperty;
- // ToDo: array argument
- Procedure TestRTTI_ClassForward;
- Procedure TestRTTI_ClassOf;
- Procedure TestRTTI_Record;
- Procedure TestRTTI_RecordAnonymousArray;
- Procedure TestRTTI_LocalTypes;
- Procedure TestRTTI_TypeInfo_BaseTypes;
- Procedure TestRTTI_TypeInfo_LocalFail;
- Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
- Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
- Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
- Procedure TestRTTI_TypeInfo_FunctionClassType;
- // Resourcestring
- Procedure TestResourcestringProgram;
- Procedure TestResourcestringUnit;
- Procedure TestResourcestringImplementation;
- // ToDo: in unit interface and implementation
- // Attributes
- Procedure TestAtributes_Ignore;
- end;
- function LinesToStr(Args: array of const): string;
- function ExtractFileUnitName(aFilename: string): string;
- function JSToStr(El: TJSElement): string;
- 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.AsAnsistring;
- finally
- aJSWriter.Free;
- aWriter.Free;
- end;
- end;
- { TTestEnginePasResolver }
- procedure TTestEnginePasResolver.SetModule(AValue: TPasModule);
- begin
- if FModule=AValue then Exit;
- if Module<>nil then
- Module.Release;
- FModule:=AValue;
- if Module<>nil then
- Module.AddRef;
- end;
- destructor TTestEnginePasResolver.Destroy;
- begin
- FreeAndNil(FResolver);
- Module:=nil;
- FreeAndNil(FParser);
- FreeAndNil(FScanner);
- FreeAndNil(FResolver);
- inherited Destroy;
- end;
- function TTestEnginePasResolver.FindModule(const AName: String): TPasModule;
- begin
- Result:=nil;
- if Assigned(OnFindUnit) then
- Result:=OnFindUnit(AName);
- end;
- { TCustomTestModule }
- function TCustomTestModule.GetResolverCount: integer;
- begin
- Result:=FModules.Count;
- end;
- function TCustomTestModule.GetResolvers(Index: integer
- ): TTestEnginePasResolver;
- begin
- Result:=TTestEnginePasResolver(FModules[Index]);
- end;
- function TCustomTestModule.OnPasResolverFindUnit(const aUnitName: String
- ): TPasModule;
- var
- DefNamespace: String;
- begin
- //writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
- if (Pos('.',aUnitName)<1) then
- begin
- DefNamespace:=GetDefaultNamespace;
- if DefNamespace<>'' then
- begin
- Result:=FindUnit(DefNamespace+'.'+aUnitName);
- if Result<>nil then exit;
- end;
- end;
- Result:=FindUnit(aUnitName);
- if Result<>nil then exit;
- writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
- Fail('can''t find unit "'+aUnitName+'"');
- end;
- function TCustomTestModule.FindUnit(const aUnitName: String): TPasModule;
- var
- i: Integer;
- CurEngine: TTestEnginePasResolver;
- CurUnitName: String;
- begin
- //writeln('TTestModule.FindUnit START Unit="',aUnitName,'"');
- Result:=nil;
- 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.Resolver:=TStreamResolver.Create;
- CurEngine.Resolver.OwnsStreams:=True;
- //writeln('TTestModule.FindUnit SOURCE=',CurEngine.Source);
- CurEngine.Resolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
- CurEngine.Scanner:=TPascalScanner.Create(CurEngine.Resolver);
- CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.Resolver,CurEngine);
- CurEngine.Parser.Options:=CurEngine.Parser.Options+po_pas2js+[po_KeepScannerError];
- 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
- inherited SetUp;
- FSkipTests:=false;
- FSource:=TStringList.Create;
- FModules:=TObjectList.Create(true);
- FFilename:='test1.pp';
- FFileResolver:=TStreamResolver.Create;
- FFileResolver.OwnsStreams:=True;
- FScanner:=TPascalScanner.Create(FFileResolver);
- FScanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
- FScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
- FScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
- FEngine:=AddModule(Filename);
- FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
- Parser.Options:=Parser.Options+po_pas2js+[po_KeepScannerError];
- FModule:=Nil;
- FConverter:=CreateConverter;
- FExpectedErrorClass:=nil;
- end;
- function TCustomTestModule.CreateConverter: TPasToJSConverter;
- begin
- Result:=TPasToJSConverter.Create;
- Result.Options:=co_tcmodules;
- end;
- procedure TCustomTestModule.TearDown;
- begin
- FSkipTests:=false;
- FJSModule:=nil;
- FJSRegModuleCall:=nil;
- FJSModuleCallArgs:=nil;
- FJSImplentationUses:=nil;
- FJSInterfaceUses:=nil;
- FJSModuleSrc:=nil;
- FJSInitBody:=nil;
- FreeAndNil(FJSSource);
- FreeAndNil(FJSModule);
- FreeAndNil(FConverter);
- Engine.Clear;
- if Assigned(FModule) then
- begin
- FModule.Release;
- FModule:=nil;
- end;
- FreeAndNil(FSource);
- FreeAndNil(FParser);
- FreeAndNil(FScanner);
- FreeAndNil(FFileResolver);
- if FModules<>nil then
- begin
- FreeAndNil(FModules);
- FEngine:=nil;
- end;
- inherited TearDown;
- 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.ParseModule;
- begin
- if SkipTests then exit;
- FFirstPasStatement:=nil;
- try
- StartParsing;
- Parser.ParseMain(FModule);
- except
- on E: Exception do
- HandleException(E);
- end;
- if SkipTests then exit;
- AssertNotNull('Module resulted in Module',FModule);
- AssertEquals('modulename',lowercase(ChangeFileExt(FFileName,'')),lowercase(Module.Name));
- TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
- end;
- procedure TCustomTestModule.ParseProgram;
- begin
- if SkipTests then exit;
- ParseModule;
- if SkipTests then exit;
- AssertEquals('Has program',TPasProgram,Module.ClassType);
- FPasProgram:=TPasProgram(Module);
- AssertNotNull('Has program section',PasProgram.ProgramSection);
- AssertNotNull('Has initialization section',PasProgram.InitializationSection);
- if (PasProgram.InitializationSection.Elements.Count>0) then
- if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
- FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
- end;
- procedure TCustomTestModule.ParseUnit;
- begin
- if SkipTests then exit;
- ParseModule;
- if SkipTests then exit;
- AssertEquals('Has unit (TPasModule)',TPasModule,Module.ClassType);
- AssertNotNull('Has interface section',Module.InterfaceSection);
- AssertNotNull('Has implementation section',Module.ImplementationSection);
- if (Module.InitializationSection<>nil)
- and (Module.InitializationSection.Elements.Count>0)
- and (TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock) then
- FFirstPasStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
- end;
- function TCustomTestModule.FindModuleWithFilename(aFilename: string
- ): TTestEnginePasResolver;
- var
- i: Integer;
- begin
- for i:=0 to ResolverCount-1 do
- if CompareText(Resolvers[i].Filename,aFilename)=0 then
- exit(Resolvers[i]);
- Result:=nil;
- end;
- function TCustomTestModule.AddModule(aFilename: string
- ): TTestEnginePasResolver;
- begin
- //writeln('TTestModuleConverter.AddModule ',aFilename);
- if FindModuleWithFilename(aFilename)<>nil then
- Fail('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
- Result:=TTestEnginePasResolver.Create;
- Result.Filename:=aFilename;
- Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
- Result.OnFindUnit:=@OnPasResolverFindUnit;
- FModules.Add(Result);
- end;
- function TCustomTestModule.AddModuleWithSrc(aFilename, Src: string
- ): TTestEnginePasResolver;
- begin
- Result:=AddModule(aFilename);
- Result.Source:=Src;
- end;
- function TCustomTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
- ImplementationSrc: string): TTestEnginePasResolver;
- var
- Src: String;
- begin
- Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
- Src+=LineEnding;
- Src+='interface'+LineEnding;
- Src+=LineEnding;
- Src+=InterfaceSrc;
- Src+='implementation'+LineEnding;
- Src+=LineEnding;
- Src+=ImplementationSrc;
- Src+='end.'+LineEnding;
- Result:=AddModuleWithSrc(aFilename,Src);
- end;
- procedure TCustomTestModule.AddSystemUnit;
- begin
- AddModuleWithIntfImplSrc('system.pp',
- // interface
- LinesToStr([
- 'type',
- ' integer=longint;',
- 'var',
- ' ExitCode: Longint;',
- ''
- // implementation
- ]),LinesToStr([
- ''
- ]));
- end;
- procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean);
- begin
- if NeedSystemUnit then
- AddSystemUnit
- else
- Parser.ImplicitUses.Clear;
- Add('program '+ExtractFileUnitName(Filename)+';');
- Add('');
- end;
- procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean);
- begin
- if NeedSystemUnit then
- AddSystemUnit
- else
- Parser.ImplicitUses.Clear;
- Add('unit Test1;');
- Add('');
- end;
- procedure TCustomTestModule.ConvertModule;
- procedure CheckUsesList(UsesName: String; Arg: TJSArrayLiteralElement;
- out UsesLit: TJSArrayLiteral);
- var
- i: Integer;
- Item: TJSElement;
- Lit: TJSLiteral;
- begin
- UsesLit:=nil;
- AssertNotNull(UsesName+' uses section',Arg.Expr);
- if (Arg.Expr.ClassType=TJSLiteral) and TJSLiteral(Arg.Expr).Value.IsNull then
- exit; // null is ok
- AssertEquals(UsesName+' uses section param is array',TJSArrayLiteral,Arg.Expr.ClassType);
- FJSInterfaceUses:=TJSArrayLiteral(Arg.Expr);
- for i:=0 to FJSInterfaceUses.Elements.Count-1 do
- begin
- Item:=FJSInterfaceUses.Elements.Elements[i].Expr;
- AssertNotNull(UsesName+' uses section item['+IntToStr(i)+'].Expr',Item);
- AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is lit',TJSLiteral,Item.ClassType);
- Lit:=TJSLiteral(Item);
- AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is string lit',
- ord(jsbase.jstString),ord(Lit.Value.ValueType));
- end;
- end;
- procedure CheckFunctionParam(ParamName: string; Arg: TJSArrayLiteralElement;
- out Src: TJSSourceElements);
- var
- FunDecl: TJSFunctionDeclarationStatement;
- FunDef: TJSFuncDef;
- FunBody: TJSFunctionBody;
- begin
- Src:=nil;
- AssertNotNull(ParamName,Arg.Expr);
- AssertEquals(ParamName+' Arg.Expr type',TJSFunctionDeclarationStatement,Arg.Expr.ClassType);
- FunDecl:=Arg.Expr as TJSFunctionDeclarationStatement;
- AssertNotNull(ParamName+' FunDecl.AFunction',FunDecl.AFunction);
- AssertEquals(ParamName+' FunDecl.AFunction type',TJSFuncDef,FunDecl.AFunction.ClassType);
- FunDef:=FunDecl.AFunction as TJSFuncDef;
- AssertEquals(ParamName+' name empty','',String(FunDef.Name));
- AssertNotNull(ParamName+' body',FunDef.Body);
- AssertEquals(ParamName+' body type',TJSFunctionBody,FunDef.Body.ClassType);
- FunBody:=FunDef.Body as TJSFunctionBody;
- AssertNotNull(ParamName+' body.A',FunBody.A);
- AssertEquals(ParamName+' body.A type',TJSSourceElements,FunBody.A.ClassType);
- Src:=FunBody.A as TJSSourceElements;
- end;
- var
- ModuleNameExpr: TJSLiteral;
- InitFunction: TJSFunctionDeclarationStatement;
- InitAssign: TJSSimpleAssignStatement;
- InitName: String;
- LastNode: TJSElement;
- Arg: TJSArrayLiteralElement;
- begin
- if SkipTests then exit;
- try
- FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements;
- except
- on E: Exception do
- HandleException(E);
- end;
- if SkipTests then exit;
- if ExpectedErrorClass<>nil then
- Fail('Missing '+ExpectedErrorClass.ClassName+' error {'+ExpectedErrorMsg+'} ('+IntToStr(ExpectedErrorNumber)+')');
- FJSSource:=TStringList.Create;
- FJSSource.Text:=ConvertJSModuleToString(JSModule);
- {$IFDEF VerbosePas2JS}
- writeln('TTestModule.ConvertModule JS:');
- write(FJSSource.Text);
- {$ENDIF}
- // rtl.module(...
- AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
- AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
- AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
- FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
- AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
- AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
- AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
- FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
- // parameter 'unitname'
- if JSModuleCallArgs.Elements.Count<1 then
- Fail('rtl.module first param unit missing');
- Arg:=JSModuleCallArgs.Elements.Elements[0];
- AssertNotNull('module name param',Arg.Expr);
- ModuleNameExpr:=Arg.Expr as TJSLiteral;
- AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
- if Module is TPasProgram then
- AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
- else
- AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
- // main uses section
- if JSModuleCallArgs.Elements.Count<2 then
- Fail('rtl.module second param main uses missing');
- Arg:=JSModuleCallArgs.Elements.Elements[1];
- CheckUsesList('interface',Arg,FJSInterfaceUses);
- // program/library/interface function()
- if JSModuleCallArgs.Elements.Count<3 then
- Fail('rtl.module third param intf-function missing');
- Arg:=JSModuleCallArgs.Elements.Elements[2];
- CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
- // search for $mod.$init or $mod.$main - the last statement
- if Module is TPasProgram then
- begin
- InitName:='$main';
- AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
- end
- else
- InitName:='$init';
- FJSInitBody:=nil;
- if JSModuleSrc.Statements.Count>0 then
- begin
- LastNode:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node;
- if LastNode is TJSSimpleAssignStatement then
- begin
- InitAssign:=LastNode as TJSSimpleAssignStatement;
- if GetDottedIdentifier(InitAssign.LHS)='$mod.'+InitName then
- begin
- InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
- FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
- end
- else if Module is TPasProgram then
- CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
- end;
- end;
- // optional: implementation uses section
- if JSModuleCallArgs.Elements.Count<4 then
- exit;
- Arg:=JSModuleCallArgs.Elements.Elements[3];
- CheckUsesList('implementation',Arg,FJSImplentationUses);
- // optional: implementation function()
- if JSModuleCallArgs.Elements.Count<5 then
- exit;
- Arg:=JSModuleCallArgs.Elements.Elements[4];
- CheckFunctionParam('module impl-function',Arg,FJSImplementationSrc);
- end;
- procedure TCustomTestModule.ConvertProgram;
- begin
- Add('end.');
- ParseProgram;
- ConvertModule;
- end;
- procedure TCustomTestModule.ConvertUnit;
- begin
- Add('end.');
- ParseUnit;
- ConvertModule;
- end;
- function TCustomTestModule.ConvertJSModuleToString(El: TJSElement): string;
- begin
- Result:=tcmodules.JSToStr(El);
- end;
- procedure TCustomTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
- DottedName: string);
- begin
- if DottedName='' then
- begin
- AssertNull(Msg,El);
- end
- else
- begin
- AssertNotNull(Msg,El);
- AssertEquals(Msg,DottedName,GetDottedIdentifier(El));
- end;
- end;
- function TCustomTestModule.GetDottedIdentifier(El: TJSElement): string;
- begin
- if El=nil then
- Result:=''
- else if El is TJSPrimaryExpressionIdent then
- Result:=String(TJSPrimaryExpressionIdent(El).Name)
- else if El is TJSDotMemberExpression then
- Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
- else
- AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
- end;
- procedure TCustomTestModule.CheckSource(Msg, Statements: String;
- InitStatements: string; ImplStatements: string);
- var
- ActualSrc, ExpectedSrc, InitName: String;
- begin
- ActualSrc:=JSToStr(JSModuleSrc);
- ExpectedSrc:=
- 'var $mod = this;'+LineEnding
- +Statements;
- if coUseStrict in Converter.Options then
- ExpectedSrc:='"use strict";'+LineEnding+ExpectedSrc;
- if Module is TPasProgram then
- InitName:='$main'
- else
- InitName:='$init';
- if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
- ExpectedSrc:=ExpectedSrc+LineEnding
- +'$mod.'+InitName+' = function () {'+LineEnding
- +InitStatements
- +'};'+LineEnding;
- //writeln('TCustomTestModule.CheckSource ExpectedIntf="',ExpectedSrc,'"');
- //writeln('TTestModule.CheckSource InitStatements="',Trim(InitStatements),'"');
- CheckDiff(Msg,ExpectedSrc,ActualSrc);
- if (JSImplementationSrc<>nil) then
- begin
- ActualSrc:=JSToStr(JSImplementationSrc);
- ExpectedSrc:=
- 'var $mod = this;'+LineEnding
- +'var $impl = $mod.$impl;'+LineEnding
- +ImplStatements;
- end
- else
- begin
- ActualSrc:='';
- ExpectedSrc:=ImplStatements;
- end;
- //writeln('TTestModule.CheckSource InitStatements="',InitStatements,'"');
- CheckDiff(Msg,ExpectedSrc,ActualSrc);
- end;
- procedure TCustomTestModule.CheckDiff(Msg, Expected, Actual: string);
- // 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 DiffFound;
- var
- ActLineStartP, ActLineEndP, p, StartPos: PChar;
- ExpLine, ActLine: String;
- i: Integer;
- begin
- writeln('Diff found "',Msg,'". Lines:');
- // write correct lines
- p:=PChar(Expected);
- repeat
- StartPos:=p;
- while not (p^ in [#0,#10,#13]) do inc(p);
- ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
- 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;
- if (p<=ExpectedP) and (p^<>#0) then begin
- writeln('= ',ExpLine);
- end else begin
- // diff line
- // write actual line
- ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
- ActLineEndP:=FindLineEnd(ActualP);
- ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
- writeln('- ',ActLine);
- // write expected line
- writeln('+ ',ExpLine);
- // write empty line with pointer ^
- for i:=1 to 2+ExpectedP-StartPos do write(' ');
- writeln('^');
- AssertEquals(Msg,ExpLine,ActLine);
- break;
- end;
- until p^=#0;
- writeln('DiffFound Actual:-----------------------');
- writeln(Actual);
- writeln('DiffFound Expected:---------------------');
- writeln(Expected);
- writeln('DiffFound ------------------------------');
- Fail('diff found, but lines are the same, internal error');
- end;
- var
- IsSpaceNeeded: Boolean;
- LastChar: Char;
- begin
- 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
- DiffFound;
- exit;
- 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
- DiffFound;
- while ActualP^ in SpaceChars do inc(ActualP);
- end;
- else
- while ActualP^ in SpaceChars do inc(ActualP);
- if ExpectedP^<>ActualP^ then
- DiffFound;
- inc(ExpectedP);
- inc(ActualP);
- end;
- until false;
- end;
- procedure TCustomTestModule.CheckUnit(Filename, ExpectedSrc: string);
- var
- aResolver: TTestEnginePasResolver;
- aConverter: TPasToJSConverter;
- aJSModule: TJSSourceElements;
- ActualSrc: String;
- begin
- aResolver:=GetResolver(Filename);
- AssertNotNull('missing resolver of unit '+Filename,aResolver);
- {$IFDEF VerbosePas2JS}
- writeln('CheckUnit '+Filename+' converting ...');
- {$ENDIF}
- aConverter:=CreateConverter;
- 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
- aConverter.Free;
- end;
- end;
- procedure TCustomTestModule.SetExpectedScannerError(Msg: string;
- MsgNumber: integer);
- begin
- ExpectedErrorClass:=EScannerError;
- ExpectedErrorMsg:=Msg;
- ExpectedErrorNumber:=MsgNumber;
- end;
- procedure TCustomTestModule.SetExpectedParserError(Msg: string;
- MsgNumber: integer);
- begin
- ExpectedErrorClass:=EParserError;
- ExpectedErrorMsg:=Msg;
- ExpectedErrorNumber:=MsgNumber;
- end;
- procedure TCustomTestModule.SetExpectedPasResolverError(Msg: string;
- MsgNumber: integer);
- begin
- ExpectedErrorClass:=EPasResolve;
- ExpectedErrorMsg:=Msg;
- ExpectedErrorNumber:=MsgNumber;
- end;
- procedure TCustomTestModule.SetExpectedConverterError(Msg: string;
- MsgNumber: integer);
- begin
- ExpectedErrorClass:=EPas2JS;
- ExpectedErrorMsg:=Msg;
- ExpectedErrorNumber:=MsgNumber;
- end;
- function TCustomTestModule.IsErrorExpected(E: Exception): boolean;
- var
- MsgNumber: Integer;
- Msg: String;
- begin
- Result:=false;
- if (ExpectedErrorClass=nil) or (ExpectedErrorClass<>E.ClassType) then exit;
- Msg:=E.Message;
- if E is EPas2JS then
- MsgNumber:=EPas2JS(E).MsgNumber
- else if E is EPasResolve then
- MsgNumber:=EPasResolve(E).MsgNumber
- else if E is EParserError then
- MsgNumber:=Parser.LastMsgNumber
- else if E is EScannerError then
- begin
- MsgNumber:=Scanner.LastMsgNumber;
- Msg:=Scanner.LastMsg;
- end
- else
- MsgNumber:=0;
- Result:=(MsgNumber=ExpectedErrorNumber) and (Msg=ExpectedErrorMsg);
- if Result then
- SkipTests:=true;
- end;
- procedure TCustomTestModule.HandleScannerError(E: EScannerError);
- begin
- if IsErrorExpected(E) then exit;
- WriteSources(Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn);
- writeln('ERROR: TCustomTestModule.HandleScannerError '+E.ClassName+':'+E.Message
- +' '+Scanner.CurFilename
- +'('+IntToStr(Scanner.CurRow)+','+IntToStr(Scanner.CurColumn)+')');
- RaiseException(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+'"'
- );
- RaiseException(E);
- end;
- procedure TCustomTestModule.HandlePasResolveError(E: EPasResolve);
- var
- P: TPasSourcePos;
- begin
- if IsErrorExpected(E) then exit;
- P:=E.SourcePos;
- WriteSources(P.FileName,P.Row,P.Column);
- writeln('ERROR: TCustomTestModule.HandlePasResolveError '+E.ClassName+':'+E.Message
- +' '+P.FileName+'('+IntToStr(P.Row)+','+IntToStr(P.Column)+')');
- RaiseException(E);
- end;
- procedure TCustomTestModule.HandlePas2JSError(E: EPas2JS);
- var
- Row, Col: integer;
- begin
- if IsErrorExpected(E) then exit;
- Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col);
- WriteSources(E.PasElement.SourceFilename,Row,Col);
- writeln('ERROR: TCustomTestModule.HandlePas2JSError '+E.ClassName+':'+E.Message
- +' '+E.PasElement.SourceFilename
- +'('+IntToStr(Row)+','+IntToStr(Col)+')');
- RaiseException(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;
- RaiseException(E);
- end;
- end;
- procedure TCustomTestModule.RaiseException(E: Exception);
- var
- MsgNumber: Integer;
- begin
- if ExpectedErrorClass<>nil then begin
- if FExpectedErrorClass=E.ClassType then begin
- if E is EPas2JS then
- MsgNumber:=EPas2JS(E).MsgNumber
- else if E is EPasResolve then
- MsgNumber:=EPasResolve(E).MsgNumber
- else if E is EParserError then
- MsgNumber:=Parser.LastMsgNumber
- else if E is EScannerError then
- MsgNumber:=Scanner.LastMsgNumber
- else
- MsgNumber:=0;
- AssertEquals('Expected error message ('+IntToStr(ExpectedErrorNumber)+')','{'+ExpectedErrorMsg+'}','{'+E.Message+'}');
- AssertEquals('Expected {'+ExpectedErrorMsg+'}, but got msg {'+E.Message+'} number',
- ExpectedErrorNumber,MsgNumber);
- end else begin
- AssertEquals('Wrong exception class',ExpectedErrorClass.ClassName,E.ClassName);
- end;
- end;
- Fail(E.Message);
- end;
- procedure TCustomTestModule.WriteSources(const aFilename: string; aRow,
- aCol: integer);
- var
- IsSrc: Boolean;
- i, j: Integer;
- SrcLines: TStringList;
- Line: string;
- aModule: TTestEnginePasResolver;
- begin
- writeln('TCustomTestModule.WriteSources File="',aFilename,'" Row=',aRow,' Col=',aCol);
- for i:=0 to ResolverCount-1 do
- begin
- aModule:=Resolvers[i];
- SrcLines:=TStringList.Create;
- try
- SrcLines.Text:=aModule.Source;
- IsSrc:=ExtractFilename(aModule.Filename)=ExtractFileName(aFilename);
- writeln('Testcode:-File="',aModule.Filename,'"----------------------------------:');
- for j:=1 to SrcLines.Count do
- begin
- Line:=SrcLines[j-1];
- if IsSrc and (j=aRow) then
- begin
- write('*');
- Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line));
- end;
- writeln(Format('%:4d: ',[j]),Line);
- end;
- finally
- SrcLines.Free;
- end;
- end;
- end;
- function TCustomTestModule.IndexOfResolver(const Filename: string): integer;
- var
- i: Integer;
- begin
- for i:=0 to ResolverCount-1 do
- if Filename=Resolvers[i].Filename then exit(i);
- Result:=-1;
- end;
- function TCustomTestModule.GetResolver(const Filename: string
- ): TTestEnginePasResolver;
- var
- i: Integer;
- begin
- i:=IndexOfResolver(Filename);
- if i<0 then exit(nil);
- Result:=Resolvers[i];
- end;
- function TCustomTestModule.GetDefaultNamespace: string;
- var
- C: TClass;
- begin
- Result:='';
- if FModule=nil then exit;
- C:=FModule.ClassType;
- if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
- Result:=Engine.DefaultNameSpace;
- end;
- { TTestModule }
- 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('implementation');
- 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' });',
- ' rtl.createClass($mod, "TTestA", $mod.TObject, function () {',
- ' });',
- '}, ["TEST.UnitB"]);'
- ]));
- CheckUnit('TEST.UnitB.pas',
- LinesToStr([
- 'rtl.module("TEST.UnitB", ["system","TEST.UnitA"], function () {',
- ' var $mod = this;',
- ' rtl.createClass($mod, "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('implementation');
- 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');
- SetExpectedScannerError('Invalid mode switch: "cblocks-"',nErrInvalidModeSwitch);
- ConvertProgram;
- 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 = 4503599627370495;');
- Add(' i5: nativeint = -4503599627370496;');
- Add(' i6: nativeint = $fffffffffffff;');
- Add(' i7: nativeint = -$10000000000000;');
- Add(' u8: nativeuint = $fffffffffffff;');
- Add(' u9: nativeuint = $0000000000000;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestVarBaseTypes',
- LinesToStr([
- 'this.i=0;',
- 'this.s="";',
- 'this.c="";',
- 'this.b=false;',
- 'this.d=0.0;',
- 'this.i2=3;',
- 'this.s2="foo";',
- 'this.c2="4";',
- 'this.b2=true;',
- 'this.d2=5.6;',
- 'this.i3=0x707;',
- 'this.i4= 4503599627370495;',
- 'this.i5= -4503599627370496;',
- 'this.i6= 0xfffffffffffff;',
- 'this.i7=-0x10000000000000;',
- 'this.u8= 0xfffffffffffff;',
- 'this.u9= 0x0000000000000;'
- ]),
- '');
- 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');
- Add(' i: longint;');
- Add(' b: boolean;');
- Add(' d: double;');
- Add(' s: string;');
- Add(' c: char;');
- Add('begin');
- Add(' i:=longint(i);');
- Add(' i:=longint(b);');
- Add(' b:=boolean(b);');
- Add(' b:=boolean(i);');
- Add(' d:=double(d);');
- Add(' d:=double(i);');
- Add(' s:=string(s);');
- Add(' s:=string(c);');
- Add(' c:=char(c);');
- ConvertProgram;
- CheckSource('TestAliasTypeRef',
- LinesToStr([ // statements
- 'this.i = 0;',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.s = "";',
- 'this.c = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.i = $mod.i;',
- '$mod.i = ($mod.b ? 1 : 0);',
- '$mod.b = $mod.b;',
- '$mod.b = $mod.i != 0;',
- '$mod.d = $mod.d;',
- '$mod.d = $mod.i;',
- '$mod.s = $mod.s;',
- '$mod.s = $mod.c;',
- '$mod.c = $mod.c;',
- '']));
- end;
- procedure TTestModule.TestTypeCast_AliasBaseTypes;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TYesNo = boolean;');
- Add(' TFloat = double;');
- Add(' TCaption = string;');
- Add(' TChar = char;');
- Add('var');
- Add(' i: integer;');
- Add(' b: TYesNo;');
- Add(' d: TFloat;');
- Add(' s: TCaption;');
- Add(' c: TChar;');
- Add('begin');
- Add(' i:=integer(i);');
- Add(' i:=integer(b);');
- Add(' b:=TYesNo(b);');
- Add(' b:=TYesNo(i);');
- Add(' d:=TFloat(d);');
- Add(' d:=TFloat(i);');
- Add(' s:=TCaption(s);');
- Add(' s:=TCaption(c);');
- Add(' c:=TChar(c);');
- ConvertProgram;
- CheckSource('TestAliasTypeRef',
- LinesToStr([ // statements
- 'this.i = 0;',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.s = "";',
- 'this.c = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.i = $mod.i;',
- '$mod.i = ($mod.b ? 1 : 0);',
- '$mod.b = $mod.b;',
- '$mod.b = $mod.i != 0;',
- '$mod.d = $mod.d;',
- '$mod.d = $mod.i;',
- '$mod.s = $mod.s;',
- '$mod.s = $mod.c;',
- '$mod.c = $mod.c;',
- '']));
- end;
- procedure TTestModule.TestEmptyProc;
- begin
- StartProgram(false);
- Add('procedure Test;');
- Add('begin');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestEmptyProc',
- LinesToStr([ // statements
- 'this.Test = function () {',
- '};'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestProcOneParam;
- begin
- StartProgram(false);
- Add('procedure ProcA(i: longint);');
- Add('begin');
- Add('end;');
- Add('begin');
- Add(' PROCA(3);');
- ConvertProgram;
- CheckSource('TestProcOneParam',
- LinesToStr([ // statements
- 'this.ProcA = function (i) {',
- '};'
- ]),
- LinesToStr([ // this.$main
- '$mod.ProcA(3);'
- ]));
- end;
- procedure TTestModule.TestFunctionWithoutParams;
- begin
- StartProgram(false);
- Add('function FuncA: longint;');
- Add('begin');
- Add('end;');
- Add('var i: longint;');
- Add('begin');
- Add(' I:=FUNCA();');
- Add(' I:=FUNCA;');
- Add(' FUNCA();');
- Add(' FUNCA;');
- ConvertProgram;
- CheckSource('TestProcWithoutParams',
- LinesToStr([ // statements
- 'this.FuncA = function () {',
- ' var Result = 0;',
- ' return Result;',
- '};',
- 'this.i=0;'
- ]),
- LinesToStr([ // this.$main
- '$mod.i=$mod.FuncA();',
- '$mod.i=$mod.FuncA();',
- '$mod.FuncA();',
- '$mod.FuncA();'
- ]));
- end;
- procedure TTestModule.TestProcedureWithoutParams;
- begin
- StartProgram(false);
- Add('procedure ProcA;');
- Add('begin');
- Add('end;');
- Add('begin');
- Add(' PROCA();');
- Add(' PROCA;');
- ConvertProgram;
- CheckSource('TestProcWithoutParams',
- LinesToStr([ // statements
- 'this.ProcA = function () {',
- '};'
- ]),
- LinesToStr([ // this.$main
- '$mod.ProcA();',
- '$mod.ProcA();'
- ]));
- end;
- procedure TTestModule.TestIncDec;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt(var i: longint);',
- 'begin',
- ' inc(i);',
- ' inc(i,2);',
- 'end;',
- 'var',
- ' Bar: longint;',
- 'begin',
- ' inc(bar);',
- ' inc(bar,2);',
- ' dec(bar);',
- ' dec(bar,3);',
- '']);
- ConvertProgram;
- CheckSource('TestIncDec',
- LinesToStr([ // statements
- 'this.DoIt = function (i) {',
- ' i.set(i.get()+1);',
- ' i.set(i.get()+2);',
- '};',
- 'this.Bar = 0;'
- ]),
- LinesToStr([ // this.$main
- '$mod.Bar+=1;',
- '$mod.Bar+=2;',
- '$mod.Bar-=1;',
- '$mod.Bar-=3;'
- ]));
- end;
- procedure TTestModule.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 = Math.floor($mod.vA / $mod.vB);',
- '$mod.vB = $mod.vA % $mod.vB;',
- '$mod.vB = ($mod.vA + ($mod.vA * $mod.vB)) + Math.floor($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.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');
- Add(' vA,vB,vC:longint;');
- Add('begin');
- Add(' va:=vb and vc;');
- Add(' va:=vb or vc;');
- Add(' va:=vb xor vc;');
- Add(' va:=vb shl vc;');
- Add(' va:=vb shr vc;');
- Add(' va:=3 and vc;');
- Add(' va:=(vb and vc) or (va and vb);');
- Add(' va:=not vb;');
- ConvertProgram;
- CheckSource('TestBitwiseOperators',
- LinesToStr([ // statements
- 'this.vA = 0;',
- 'this.vB = 0;',
- 'this.vC = 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;'
- ]));
- 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.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.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.TestBreak;
- begin
- StartProgram(false);
- Add('var i: longint;');
- Add('begin');
- Add(' repeat');
- Add(' break;');
- Add(' until true;');
- Add(' while true do');
- Add(' break;');
- Add(' for i:=1 to 2 do');
- Add(' 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.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('TestProcedureExternal',
- 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('TestProcedureExternalOtherUnit',
- 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([
- 'function DoIt: longint;',
- 'begin;',
- ' asm',
- ' { a:{ b:{}, c:[]}, d:''1'' };',
- ' end;',
- ' asm console.log(); end;',
- 'end;',
- 'begin']);
- ConvertProgram;
- CheckSource('TestProcedureAsm',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' var Result = 0;',
- ' { a:{ b:{}, c:[]}, d:''1'' };',
- ' console.log();',
- ' return Result;',
- '};'
- ]),
- 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('TestProcedureAssembler',
- 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('TestProcedure_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_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_OverloadUnit;
- 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); 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('TestProcedureOverloadNested',
- 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_Varargs;
- begin
- StartProgram(false);
- Add('procedure ProcA(i:longint); varargs; external name ''ProcA'';');
- Add('procedure ProcB; varargs; external name ''ProcB'';');
- Add('procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';');
- Add('function GetIt: longint; begin end;');
- Add('begin');
- Add(' ProcA(1);');
- Add(' ProcA(1,2);');
- Add(' ProcA(1,2.0);');
- Add(' ProcA(1,2,3);');
- Add(' ProcA(1,''2'');');
- Add(' ProcA(2,'''');');
- Add(' ProcA(3,false);');
- Add(' ProcB;');
- Add(' ProcB();');
- Add(' ProcB(4);');
- Add(' ProcB(''foo'');');
- Add(' ProcC;');
- Add(' ProcC();');
- Add(' ProcC(4);');
- Add(' ProcC(5,''foo'');');
- Add(' ProcB(GetIt);');
- Add(' ProcB(GetIt());');
- Add(' 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 = $mod.A + 1;',
- 'var C = $mod.A + 1;',
- 'var D = $mod.B + 1;',
- 'var E = ((D + C) + $mod.B) + $mod.A;',
- 'this.DoIt = function () {',
- '};',
- '']),
- LinesToStr([
- ''
- ]));
- 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;');
- ConvertProgram;
- CheckSource('TestEnumName',
- LinesToStr([ // statements
- 'this.TMyEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1,',
- ' "2":"Blue",',
- ' Blue:2',
- ' };',
- 'this.e = 0;',
- 'this.f = $mod.TMyEnum.Blue;'
- ]),
- LinesToStr([
- '$mod.e=$mod.TMyEnum.Green;'
- ]));
- 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_Functions;
- begin
- StartProgram(false);
- Add('type TMyEnum = (Red, Green);');
- Add('var');
- Add(' e: TMyEnum;');
- Add(' i: longint;');
- Add(' s: string;');
- Add(' b: boolean;');
- Add('begin');
- Add(' i:=ord(red);');
- Add(' i:=ord(green);');
- Add(' i:=ord(e);');
- Add(' i:=ord(b);');
- Add(' e:=low(tmyenum);');
- Add(' e:=low(e);');
- Add(' b:=low(boolean);');
- Add(' e:=high(tmyenum);');
- Add(' e:=high(e);');
- Add(' b:=high(boolean);');
- Add(' e:=pred(green);');
- Add(' e:=pred(e);');
- Add(' b:=pred(b);');
- Add(' e:=succ(red);');
- Add(' e:=succ(e);');
- Add(' b:=succ(b);');
- Add(' e:=tmyenum(1);');
- Add(' e:=tmyenum(i);');
- Add(' s:=str(e);');
- Add(' str(e,s);');
- Add(' s:=str(e:3);');
- Add(' e:=TMyEnum(i);');
- Add(' i:=longint(e);');
- ConvertProgram;
- CheckSource('TestEnum_Functions',
- LinesToStr([ // statements
- 'this.TMyEnum = {',
- ' "0":"Red",',
- ' Red:0,',
- ' "1":"Green",',
- ' Green:1',
- ' };',
- '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 = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3);',
- '$mod.e=$mod.i;',
- '$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;',
- 'var',
- ' a: TArr;',
- ' b: TArr = (3,4);',
- 'begin',
- ' a[green] := b[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];',
- '']),
- LinesToStr([
- ' $mod.a[$mod.TEnum.Green - 1] = $mod.b[$mod.TEnum.Blue - 1];',
- '']));
- end;
- procedure TTestModule.TestSet;
- begin
- StartProgram(false);
- Add('type');
- Add(' TColor = (Red, Green, Blue);');
- Add(' TColors = set of TColor;');
- Add('var');
- Add(' c: TColor;');
- Add(' s: TColors;');
- Add(' t: TColors = [];');
- Add(' u: TColors = [Red];');
- Add('begin');
- Add(' s:=[];');
- Add(' s:=[Green];');
- Add(' s:=[Green,Blue];');
- Add(' s:=[Red..Blue];');
- Add(' s:=[Red,Green..Blue];');
- Add(' s:=[Red,c];');
- Add(' s:=t;');
- ConvertProgram;
- CheckSource('TestEnumName',
- 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($mod.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);',
- '']));
- 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');
- Add(' TColor = (Red, Green, Blue);');
- Add(' TColors = set of tcolor;');
- Add('var');
- Add(' vC: tcolor;');
- Add(' vT: tcolors;');
- Add(' B: boolean;');
- Add('begin');
- Add(' b:=red in vt;');
- Add(' b:=vc in vt;');
- Add(' b:=green in [red..blue];');
- Add(' b:=vc in [red..blue];');
- Add(' ');
- Add(' if red in vt then ;');
- Add(' while vC in vt do ;');
- Add(' repeat');
- Add(' until vC in vt;');
- 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;'
- ]),
- 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));',
- '']));
- 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);');
- Add('type TEnums = set of TEnum;');
- Add('procedure DoIt(vG: TEnums; const vH: TEnums; var vI: TEnums);');
- Add('var vJ: TEnums;');
- 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: TEnums;');
- Add('begin');
- Add(' 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 vJ = {};',
- ' 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;',
- ' }',
- ' });',
- '};',
- '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($mod, "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');
- Add(' TEnum = (Red,Blue);');
- Add(' TEnums = set of TEnum;');
- Add('const');
- Add(' Orange = red;');
- Add('var');
- Add(' Enum: tenum;');
- Add(' Enums: tenums;');
- Add('begin');
- Add(' Include(enums,orange);');
- Add(' Exclude(enums,orange);');
- Add(' if orange in enums then;');
- Add(' if orange in [orange,red] then;');
- ConvertProgram;
- CheckSource('TestEnumConst',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "Red",',
- ' Red: 0,',
- ' "1": "Blue",',
- ' Blue: 1',
- '};',
- 'this.Orange = $mod.TEnum.Red;',
- 'this.Enum = 0;',
- 'this.Enums = {};',
- '']),
- LinesToStr([
- '$mod.Enums = rtl.includeSet($mod.Enums, $mod.Orange);',
- '$mod.Enums = rtl.excludeSet($mod.Enums, $mod.Orange);',
- 'if ($mod.Orange in $mod.Enums) ;',
- 'if ($mod.Orange in rtl.createSet($mod.Orange, $mod.TEnum.Red)) ;',
- '']));
- 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 = $mod.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.favorite);',
- '$mod.i = $mod.TFlags$a.red;',
- '$mod.i = $mod.favorite;',
- '$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.favorite);',
- '']));
- 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, $mod.TEnum.red, $mod.TEnum.green);',
- 'this.teRedBlue = rtl.createSet(null, $mod.TEnum.red, $mod.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''];',
- '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 ;',
- '']);
- ConvertProgram;
- CheckSource('TestSet_ConstChar',
- LinesToStr([ // statements
- 'this.LowChars = rtl.createSet(null, 97, 122);',
- 'this.Chars = rtl.unionSet($mod.LowChars, rtl.createSet(null, 65, 90));',
- 'this.c = "";',
- 'this.s = "";',
- '']),
- LinesToStr([
- 'if ($mod.c.charCodeAt() in $mod.LowChars) ;',
- 'if (97 in $mod.LowChars) ;',
- 'if ($mod.s.charCodeAt(0) in $mod.LowChars) ;',
- 'if ($mod.c.charCodeAt() in $mod.Chars) ;',
- 'if ($mod.c.charCodeAt() in rtl.createSet(null, 97, 122, 95)) ;',
- 'if (98 in rtl.createSet(null, 97, 122, 95)) ;',
- '']));
- 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), $mod.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.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
- '$impl.TMyRecord = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- '$impl.aRec = new $impl.TMyRecord();',
- '']) );
- 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 + csA;',
- ' cA = (cA + csA) + 5;',
- ' };',
- ' cA = (cA + cB) + 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.TestDouble;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' d: double;',
- 'begin',
- ' d:=1.0;',
- ' d:=1.0/3.0;',
- ' d:=1/3;',
- ' d:=5.0E-324;',
- ' d:=1.7E308;',
- ' d:=10**3;',
- ' d:=10 mod 3;',
- ' d:=10 div 3;',
- '']);
- ConvertProgram;
- CheckSource('TestDouble',
- LinesToStr([
- 'this.d=0.0;'
- ]),
- LinesToStr([
- '$mod.d = 1.0;',
- '$mod.d = 1.0 / 3.0;',
- '$mod.d = 1 / 3;',
- '$mod.d = 5.0E-324;',
- '$mod.d = 1.7E308;',
- '$mod.d = Math.pow(10, 3);',
- '$mod.d = 10 % 3;',
- '$mod.d = Math.floor(10 / 3);',
- '']));
- 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;',
- ' if i=i2 then ;']);
- 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 $mod.s2;',
- 'this.i = -1;',
- 'this.i2 = 1;',
- '']),
- LinesToStr([
- '$mod.i = $mod.i2;',
- 'if ($mod.i === $mod.i2) ;',
- '']));
- end;
- procedure TTestModule.TestForBoolDo;
- begin
- StartProgram(false);
- Add([
- 'var b: boolean;',
- 'begin',
- ' for b:=false to true do ;',
- ' for b:=b downto false do ;',
- '']);
- ConvertProgram;
- CheckSource('TestForBoolDo',
- LinesToStr([ // statements
- 'this.b = false;']),
- LinesToStr([ // this.$main
- 'for (var $l1 = 0; $l1 <= 1; $l1++) $mod.b = $l1 != 0;',
- 'for (var $l2 = +$mod.b; $l2 >= 0; $l2--) $mod.b = $l2 != 0;',
- '']));
- end;
- procedure TTestModule.TestCharConst;
- begin
- StartProgram(false);
- Add('const');
- Add(' c: char = ''1'';');
- Add('begin');
- Add(' c:=#0;');
- Add(' c:=#1;');
- Add(' c:=#9;');
- Add(' c:=#10;');
- Add(' c:=#13;');
- Add(' c:=#31;');
- Add(' c:=#32;');
- Add(' c:=#$A;');
- Add(' c:=#$0A;');
- Add(' c:=#$b;');
- Add(' c:=#$0b;');
- Add(' c:=^A;');
- Add(' c:=''"'';');
- ConvertProgram;
- CheckSource('TestCharConst',
- LinesToStr([
- 'this.c="1";'
- ]),
- 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=''"'';'
- ]));
- end;
- procedure TTestModule.TestChar_Compare;
- begin
- StartProgram(false);
- Add('var');
- Add(' c: char;');
- Add(' b: boolean;');
- Add('begin');
- Add(' b:=c=''1'';');
- Add(' b:=''2''=c;');
- Add(' b:=''3''=''4'';');
- Add(' b:=c<>''5'';');
- Add(' b:=''6''<>c;');
- Add(' b:=c>''7'';');
- Add(' b:=''8''>c;');
- Add(' b:=c>=''9'';');
- Add(' b:=''A''>=c;');
- Add(' b:=c<''B'';');
- Add(' b:=''C''<c;');
- Add(' b:=c<=''D'';');
- Add(' b:=''E''<=c;');
- ConvertProgram;
- CheckSource('TestChar_Compare',
- LinesToStr([
- 'this.c="";',
- 'this.b = false;'
- ]),
- LinesToStr([
- '$mod.b = $mod.c === "1";',
- '$mod.b = "2" === $mod.c;',
- '$mod.b = "3" === "4";',
- '$mod.b = $mod.c !== "5";',
- '$mod.b = "6" !== $mod.c;',
- '$mod.b = $mod.c > "7";',
- '$mod.b = "8" > $mod.c;',
- '$mod.b = $mod.c >= "9";',
- '$mod.b = "A" >= $mod.c;',
- '$mod.b = $mod.c < "B";',
- '$mod.b = "C" < $mod.c;',
- '$mod.b = $mod.c <= "D";',
- '$mod.b = "E" <= $mod.c;',
- '']));
- end;
- procedure TTestModule.TestChar_Ord;
- begin
- StartProgram(false);
- Add('var');
- Add(' c: char;');
- Add(' i: longint;');
- Add(' s: string;');
- Add('begin');
- Add(' i:=ord(c);');
- Add(' i:=ord(s[i]);');
- ConvertProgram;
- CheckSource('TestChar_Ord',
- LinesToStr([
- 'this.c = "";',
- 'this.i = 0;',
- 'this.s = "";'
- ]),
- LinesToStr([
- '$mod.i = $mod.c.charCodeAt();',
- '$mod.i = $mod.s.charCodeAt($mod.i-1);',
- '']));
- end;
- procedure TTestModule.TestChar_Chr;
- begin
- StartProgram(false);
- Add('var');
- Add(' c: char;');
- Add(' i: longint;');
- Add('begin');
- Add(' c:=chr(i);');
- ConvertProgram;
- CheckSource('TestChar_Chr',
- LinesToStr([
- 'this.c = "";',
- 'this.i = 0;'
- ]),
- LinesToStr([
- '$mod.c = String.fromCharCode($mod.i);',
- '']));
- end;
- procedure TTestModule.TestStringConst;
- begin
- StartProgram(false);
- Add('var');
- Add(' s: string = ''abc'';');
- Add('begin');
- Add(' s:='''';');
- Add(' s:=#13#10;');
- Add(' s:=#9''foo'';');
- Add(' s:=#$A9;');
- Add(' s:=''foo''#13''bar'';');
- Add(' s:=''"'';');
- Add(' s:=''"''''"'';');
- ConvertProgram;
- CheckSource('TestStringConst',
- LinesToStr([
- 'this.s="abc";'
- ]),
- LinesToStr([
- '$mod.s="";',
- '$mod.s="\r\n";',
- '$mod.s="\tfoo";',
- '$mod.s="©";',
- '$mod.s="foo\rbar";',
- '$mod.s=''"'';',
- '$mod.s=''"\''"'';'
- ]));
- end;
- procedure TTestModule.TestString_Length;
- begin
- StartProgram(false);
- Add('const c = ''foo'';');
- Add('var');
- Add(' s: string;');
- Add(' i: longint;');
- Add('begin');
- Add(' i:=length(s);');
- Add(' i:=length(s+s);');
- Add(' i:=length(''abc'');');
- Add(' i:=length(c);');
- ConvertProgram;
- CheckSource('TestString_Length',
- LinesToStr([
- 'this.c = "foo";',
- 'this.s = "";',
- 'this.i = 0;',
- '']),
- LinesToStr([
- '$mod.i = $mod.s.length;',
- '$mod.i = ($mod.s+$mod.s).length;',
- '$mod.i = "abc".length;',
- '$mod.i = $mod.c.length;',
- '']));
- end;
- procedure TTestModule.TestString_Compare;
- begin
- StartProgram(false);
- Add('var');
- Add(' s, t: string;');
- Add(' b: boolean;');
- Add('begin');
- Add(' b:=s=t;');
- Add(' b:=s<>t;');
- Add(' b:=s>t;');
- Add(' b:=s>=t;');
- Add(' b:=s<t;');
- Add(' b:=s<=t;');
- ConvertProgram;
- CheckSource('TestString_Compare',
- LinesToStr([ // statements
- 'this.s = "";',
- 'this.t = "";',
- 'this.b =false;'
- ]),
- LinesToStr([ // this.$main
- '$mod.b = $mod.s === $mod.t;',
- '$mod.b = $mod.s !== $mod.t;',
- '$mod.b = $mod.s > $mod.t;',
- '$mod.b = $mod.s >= $mod.t;',
- '$mod.b = $mod.s < $mod.t;',
- '$mod.b = $mod.s <= $mod.t;',
- '']));
- end;
- procedure TTestModule.TestString_SetLength;
- begin
- StartProgram(false);
- Add([
- 'procedure DoIt(var s: string);',
- 'begin',
- ' SetLength(s,2);',
- 'end;',
- 'var s: string;',
- 'begin',
- ' SetLength(s,3);',
- '']);
- ConvertProgram;
- CheckSource('TestString_SetLength',
- LinesToStr([ // statements
- 'this.DoIt = function (s) {',
- ' s.set(rtl.strSetLength(s.get(), 2));',
- '};',
- 'this.s = "";',
- '']),
- LinesToStr([ // this.$main
- '$mod.s = rtl.strSetLength($mod.s, 3);'
- ]));
- end;
- procedure TTestModule.TestString_CharAt;
- begin
- StartProgram(false);
- Add('var');
- Add(' s: string;');
- Add(' c: char;');
- Add(' b: boolean;');
- Add('begin');
- Add(' b:= s[1] = c;');
- Add(' b:= c = s[1];');
- Add(' b:= c <> s[1];');
- Add(' b:= c > s[1];');
- Add(' b:= c >= s[1];');
- Add(' b:= c < s[2];');
- Add(' b:= c <= s[1];');
- Add(' s[1] := c;');
- Add(' s[2+3] := c;');
- ConvertProgram;
- CheckSource('TestString_CharAt',
- LinesToStr([ // statements
- 'this.s = "";',
- 'this.c = "";',
- 'this.b = false;'
- ]),
- LinesToStr([ // this.$main
- '$mod.b = $mod.s.charAt(0) === $mod.c;',
- '$mod.b = $mod.c === $mod.s.charAt(0);',
- '$mod.b = $mod.c !== $mod.s.charAt(0);',
- '$mod.b = $mod.c > $mod.s.charAt(0);',
- '$mod.b = $mod.c >= $mod.s.charAt(0);',
- '$mod.b = $mod.c < $mod.s.charAt(1);',
- '$mod.b = $mod.c <= $mod.s.charAt(0);',
- '$mod.s = rtl.setCharAt($mod.s, 0, $mod.c);',
- '$mod.s = rtl.setCharAt($mod.s, (2 + 3) - 1, $mod.c);',
- '']));
- end;
- procedure TTestModule.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 ;',
- '']);
- ConvertProgram;
- CheckSource('TestCharSet_Custom',
- LinesToStr([ // statements
- 'this.crg = "b";',
- 'this.c = "";',
- 'this.crg2 = "m";',
- 'this.s = {};',
- '']),
- LinesToStr([ // this.$main
- '$mod.c = $mod.crg;',
- '$mod.crg = $mod.c;',
- '$mod.crg2 = $mod.crg;',
- 'if ($mod.c === $mod.crg) ;',
- 'if ($mod.crg === $mod.c) ;',
- 'if ($mod.crg === $mod.crg2) ;',
- 'if ($mod.c.charCodeAt() in $mod.s) ;',
- 'if ($mod.crg2.charCodeAt() in $mod.s) ;',
- '']));
- end;
- procedure TTestModule.TestForCharDo;
- begin
- StartProgram(false);
- Add([
- 'var c: char;',
- 'begin',
- ' for c:=''a'' to ''c'' do ;',
- ' for c:=c downto ''a'' do ;',
- '']);
- ConvertProgram;
- CheckSource('TestForCharDo',
- LinesToStr([ // statements
- 'this.c = "";']),
- LinesToStr([ // this.$main
- 'for (var $l1 = 97; $l1 <= 99; $l1++) $mod.c = String.fromCharCode($l1);',
- 'for (var $l2 = $mod.c.charCodeAt(); $l2 >= 97; $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: char;',
- ' s: string;',
- ' a1: array of char;',
- ' a2: array[1..3] of char;',
- ' a3: array[1..3,4..5] 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 a3 do ;',
- //' for c in [''1''..''3''] do ;',
- //' for c in TSetOfChar do ;',
- //' for c in TCharRg do ;',
- //' for c in soc do ;',
- //' for c in TSetOfCharRg do ;',
- //' for c in socr do ;',
- //' for cr in TCharRg do ;',
- //' for cr in TSetOfCharRg do ;',
- //' for cr in socr do ;',
- '']);
- ConvertProgram;
- CheckSource('TestForCharInDo',
- LinesToStr([ // statements
- 'this.Foo = "foo";',
- 'this.c = "";',
- 'this.s = "";',
- 'this.a1 = [];',
- 'this.a2 = rtl.arraySetLength(null, "", 3);',
- 'this.a3 = rtl.arraySetLength(null, "", 3, 2);',
- 'this.soc = {};',
- 'this.socr = {};',
- 'this.cr = "a";',
- '']),
- LinesToStr([ // this.$main
- 'for (var ($in1 = $mod.Foo, $l2 = 0), $end3 = $in1.length - 1; $l2 <= $end3; $l2++) $mod.c = $in1.charAt($l2);',
- 'for (var ($in4 = $mod.s, $l5 = 0), $end6 = $in4.length - 1; $l5 <= $end6; $l5++) $mod.c = $in4.charAt($l5);',
- 'for (var $l7 = 0, $end8 = 65535; $l7 <= $end8; $l7++) $mod.c = String.fromCharCode($l7);',
- '']));
- 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.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 $l1 = 1, $end2 = $mod.vN; $l1 <= $end2; $l1++) {',
- ' $mod.vI = $l1;',
- ' $mod.vJ = $mod.vJ + $mod.vI;',
- ' };',
- '']));
- end;
- procedure TTestModule.TestForLoopInFunction;
- 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('TestForLoopInFunction',
- LinesToStr([ // statements
- 'this.SumNumbers = function (Count) {',
- ' var Result = 0;',
- ' var vI = 0;',
- ' var vJ = 0;',
- ' vJ = 0;',
- ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
- ' vI = $l1;',
- ' 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 $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
- ' vI = $l1;',
- ' for (var $l3 = 1, $end4 = vI; $l3 <= $end4; $l3++) {',
- ' vJ = $l3;',
- ' 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');
- Add(' vI: longint;');
- Add('begin');
- Add(' vi:=1;');
- Add(' asm');
- Add(' if (vI===1) {');
- Add(' vI=2;');
- Add(' }');
- Add(' if (vI===2){ vI=3; }');
- Add(' end;');
- Add(' 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;
- // ToDo: check use analyzer
- 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 = Math.floor(2 / $mod.i);',
- '} finally {',
- ' $mod.i = 3;',
- '};'
- ]));
- end;
- procedure TTestModule.TestTryExcept;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class end;');
- Add(' Exception = class Msg: string; end;');
- Add(' EInvalidCast = class(Exception) end;');
- Add('var vI: longint;');
- Add('begin');
- Add(' try');
- Add(' vi:=1;');
- Add(' except');
- Add(' vi:=2');
- Add(' end;');
- Add(' try');
- Add(' vi:=3;');
- Add(' except');
- Add(' raise;');
- Add(' end;');
- Add(' try');
- Add(' VI:=4;');
- Add(' except');
- Add(' on einvalidcast do');
- Add(' raise;');
- Add(' on E: exception do');
- Add(' if e.msg='''' then');
- Add(' raise e;');
- Add(' else');
- Add(' vi:=5');
- Add(' end;');
- Add(' try');
- Add(' VI:=6;');
- Add(' except');
- Add(' on einvalidcast do ;');
- Add(' end;');
- ConvertProgram;
- CheckSource('TestTryExcept',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.Msg = "";',
- ' };',
- '});',
- 'rtl.createClass($mod, "EInvalidCast", $mod.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.TestCaseOf;
- begin
- StartProgram(false);
- 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',
- LinesToStr([ // statements
- 'this.vI = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $tmp1 = $mod.vI;',
- 'if ($tmp1 === 1) {} else if ($tmp1 === 2){ $mod.vI = 3 }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 $tmp1 = $mod.Vi;',
- 'if ($tmp1 === 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 $tmp1 = $mod.vI;',
- 'if (($tmp1 >= 1) && ($tmp1 <= 3)){',
- ' $mod.vI = 14',
- '} else if (($tmp1 === 4) || ($tmp1 === 5)){',
- ' $mod.vI = 16',
- '} else if ((($tmp1 >= 6) && ($tmp1 <= 7)) || (($tmp1 >= 9) && ($tmp1 <= 10))) ;'
- ]));
- end;
- procedure TTestModule.TestArray_Dynamic;
- begin
- StartProgram(false);
- Add('type');
- Add(' TArrayInt = array of longint;');
- Add('var');
- Add(' Arr: TArrayInt;');
- Add(' i: longint;');
- Add(' b: boolean;');
- Add('begin');
- Add(' SetLength(arr,3);');
- Add(' arr[0]:=4;');
- Add(' arr[1]:=length(arr)+arr[0];');
- Add(' arr[i]:=5;');
- Add(' arr[arr[i]]:=arr[6];');
- Add(' i:=low(arr);');
- Add(' i:=high(arr);');
- Add(' b:=Assigned(arr);');
- 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;',
- '']));
- 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');
- Add(' TArrayInt = array of longint;');
- Add(' TArrayArrayInt = array of TArrayInt;');
- Add('var');
- Add(' Arr: TArrayInt;');
- Add(' Arr2: TArrayArrayInt;');
- Add(' i: longint;');
- Add('begin');
- Add(' arr2:=nil;');
- Add(' if arr2=nil then;');
- Add(' if nil=arr2 then;');
- Add(' i:=low(arr2);');
- Add(' i:=low(arr2[1]);');
- Add(' i:=high(arr2);');
- Add(' i:=high(arr2[2]);');
- Add(' arr2[3]:=arr;');
- Add(' arr2[4][5]:=i;');
- Add(' i:=arr2[6][7];');
- Add(' arr2[8,9]:=i;');
- Add(' i:=arr2[10,11];');
- Add(' SetLength(arr2,14);');
- Add(' 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] = $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_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];');
- 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];',
- '']));
- 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');
- Add(' TChars = array[char] of char;');
- Add(' TChars2 = array[''a''..''z''] of char;');
- Add('var');
- Add(' Arr: TChars;');
- Add(' Arr2: TChars2;');
- Add(' Arr3: array[2..4] of char = (''p'',''a'',''s'');');
- Add(' Arr4: array[11..13] of char = ''pas'';');
- Add(' Arr5: array[21..22] of char = ''äö'';');
- Add(' c: char;');
- Add(' b: boolean;');
- Add('begin');
- Add(' c:=low(arr);');
- Add(' c:=high(arr);');
- Add(' arr[''B'']:=''a'';');
- Add(' arr[''D'']:=arr[c];');
- Add(' arr[c]:=arr[''d''];');
- Add(' arr[arr[c]]:=arr[high(arr)];');
- Add(' b:=arr[low(arr)]=arr[''e''];');
- Add(' c:=low(arr2);');
- Add(' c:=high(arr2);');
- Add(' arr2[''b'']:=''f'';');
- Add(' arr2[''a'']:=arr2[c];');
- Add(' arr2[c]:=arr2[''g''];');
- ConvertProgram;
- CheckSource('TestArray_StaticChar',
- LinesToStr([ // statements
- 'this.Arr = rtl.arraySetLength(null, "", 65536);',
- 'this.Arr2 = rtl.arraySetLength(null, "", 26);',
- 'this.Arr3 = ["p", "a", "s"];',
- 'this.Arr4 = ["p", "a", "s"];',
- 'this.Arr5 = ["ä", "ö"];',
- 'this.c = "";',
- 'this.b = false;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.c = "\x00";',
- '$mod.c = "'#$EF#$BF#$BF'";',
- '$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
- exit;
- StartProgram(false);
- Add('type');
- Add(' TArrayInt = array[1..3] of longint;');
- Add(' TArrayArrayInt = array[5..6] of TArrayInt;');
- Add('var');
- Add(' Arr: TArrayInt;');
- Add(' Arr2: TArrayArrayInt;');
- Add(' i: longint;');
- Add('begin');
- Add(' i:=low(arr);');
- Add(' i:=low(arr2);');
- Add(' i:=low(arr2[5]);');
- Add(' i:=high(arr);');
- Add(' i:=high(arr2);');
- Add(' i:=high(arr2[6]);');
- Add(' arr2[3]:=arr;');
- Add(' arr2[4][5]:=i;');
- Add(' i:=arr2[6][7];');
- Add(' arr2[8,9]:=i;');
- Add(' i:=arr2[10,11];');
- Add(' SetLength(arr2,14);');
- Add(' SetLength(arr2[15],16);');
- ConvertProgram;
- CheckSource('TestArray_StaticMultiDim',
- 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] = $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.TestArrayOfRecord;
- begin
- StartProgram(false);
- Add('type');
- Add(' TRec = record');
- Add(' Int: longint;');
- Add(' end;');
- Add(' TArrayRec = array of TRec;');
- Add('var');
- Add(' Arr: TArrayRec;');
- Add(' r: TRec;');
- Add(' i: longint;');
- Add('begin');
- Add(' SetLength(arr,3);');
- Add(' arr[0].int:=4;');
- Add(' arr[1].int:=length(arr)+arr[2].int;');
- Add(' arr[arr[i].int].int:=arr[5].int;');
- Add(' arr[7]:=r;');
- Add(' r:=arr[8];');
- Add(' i:=low(arr);');
- Add(' i:=high(arr);');
- ConvertProgram;
- CheckSource('TestArrayOfRecord',
- LinesToStr([ // statements
- 'this.TRec = function (s) {',
- ' if (s) {',
- ' this.Int = s.Int;',
- ' } else {',
- ' this.Int = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.Int === b.Int;',
- ' };',
- '};',
- 'this.Arr = [];',
- 'this.r = new $mod.TRec();',
- '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] = new $mod.TRec($mod.r);',
- '$mod.r = new $mod.TRec($mod.Arr[8]);',
- '$mod.i = 0;',
- '$mod.i = rtl.length($mod.Arr)-1;',
- '']));
- end;
- procedure TTestModule.TestArray_AsParams;
- begin
- StartProgram(false);
- Add('type integer = longint;');
- Add('type TArrInt = array of integer;');
- Add('procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);');
- Add('var vJ: TArrInt;');
- 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: TArrInt;');
- Add('begin');
- Add(' doit(i,i,i);');
- ConvertProgram;
- CheckSource('TestArray_AsParams',
- LinesToStr([ // statements
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = [];',
- ' 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 = [];'
- ]),
- 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.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');
- Add(' TEnum = (red,blue);');
- Add(' TEnumArray = array[TEnum] of longint;');
- Add('var');
- Add(' e: TEnum;');
- Add(' i: longint;');
- Add(' a: TEnumArray;');
- Add(' numbers: TEnumArray = (1,2);');
- Add(' names: array[TEnum] of string = (''red'',''blue'');');
- Add('begin');
- Add(' e:=low(a);');
- Add(' e:=high(a);');
- Add(' i:=a[red];');
- Add(' 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($mod, "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;',
- 'var',
- ' a: TArrArrInt;',
- 'begin',
- ' SetLength(a,2);',
- ' SetLength(a,3,4);',
- '']);
- ConvertProgram;
- CheckSource('TestArray_SetLengthMultiDim',
- LinesToStr([ // statements
- 'this.a = [];']),
- LinesToStr([
- '$mod.a = rtl.arraySetLength($mod.a, [], 2);',
- '$mod.a = rtl.arraySetLength($mod.a, 0, 3, 4);',
- '']));
- 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 $l1 = 0, $end2 = rtl.length(a) - 1; $l1 <= $end2; $l1++) {',
- ' i = $l1;',
- ' 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_Concat;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TFlag = (big,small);');
- Add(' TFlags = set of TFlag;');
- Add(' TRec = record');
- Add(' i: integer;');
- Add(' end;');
- Add(' TArrInt = array of integer;');
- Add(' TArrRec = array of TRec;');
- Add(' TArrSet = array of TFlags;');
- Add(' TArrJSValue = array of jsvalue;');
- Add('var');
- Add(' ArrInt: tarrint;');
- Add(' ArrRec: tarrrec;');
- Add(' ArrSet: tarrset;');
- Add(' ArrJSValue: tarrjsvalue;');
- Add('begin');
- Add(' arrint:=concat(arrint);');
- Add(' arrint:=concat(arrint,arrint);');
- Add(' arrint:=concat(arrint,arrint,arrint);');
- Add(' arrrec:=concat(arrrec);');
- Add(' arrrec:=concat(arrrec,arrrec);');
- Add(' arrrec:=concat(arrrec,arrrec,arrrec);');
- Add(' arrset:=concat(arrset);');
- Add(' arrset:=concat(arrset,arrset);');
- Add(' arrset:=concat(arrset,arrset,arrset);');
- Add(' arrjsvalue:=concat(arrjsvalue);');
- Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue);');
- Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);');
- ConvertProgram;
- CheckSource('TestArray_Concat',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "big",',
- ' big: 0,',
- ' "1": "small",',
- ' small: 1',
- '};',
- 'this.TRec = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- 'this.ArrInt = [];',
- 'this.ArrRec = [];',
- 'this.ArrSet = [];',
- 'this.ArrJSValue = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ArrInt = $mod.ArrInt;',
- '$mod.ArrInt = $mod.ArrInt.concat($mod.ArrInt);',
- '$mod.ArrInt = $mod.ArrInt.concat($mod.ArrInt,$mod.ArrInt);',
- '$mod.ArrRec = $mod.ArrRec;',
- '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec);',
- '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec);',
- '$mod.ArrSet = $mod.ArrSet;',
- '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet);',
- '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet);',
- '$mod.ArrJSValue = $mod.ArrJSValue;',
- '$mod.ArrJSValue = $mod.ArrJSValue.concat($mod.ArrJSValue);',
- '$mod.ArrJSValue = $mod.ArrJSValue.concat($mod.ArrJSValue, $mod.ArrJSValue);',
- '']));
- end;
- procedure TTestModule.TestArray_Copy;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TFlag = (big,small);');
- Add(' TFlags = set of TFlag;');
- Add(' TRec = record');
- Add(' i: integer;');
- Add(' end;');
- Add(' TArrInt = array of integer;');
- Add(' TArrRec = array of TRec;');
- Add(' TArrSet = array of TFlags;');
- Add(' TArrJSValue = array of jsvalue;');
- Add('var');
- Add(' ArrInt: tarrint;');
- Add(' ArrRec: tarrrec;');
- Add(' ArrSet: tarrset;');
- Add(' ArrJSValue: tarrjsvalue;');
- Add('begin');
- Add(' arrint:=copy(arrint);');
- Add(' arrint:=copy(arrint,2);');
- Add(' arrint:=copy(arrint,3,4);');
- Add(' arrrec:=copy(arrrec);');
- Add(' arrrec:=copy(arrrec,5);');
- Add(' arrrec:=copy(arrrec,6,7);');
- Add(' arrset:=copy(arrset);');
- Add(' arrset:=copy(arrset,8);');
- Add(' arrset:=copy(arrset,9,10);');
- Add(' arrjsvalue:=copy(arrjsvalue);');
- Add(' arrjsvalue:=copy(arrjsvalue,11);');
- Add(' arrjsvalue:=copy(arrjsvalue,12,13);');
- ConvertProgram;
- CheckSource('TestArray_Copy',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "big",',
- ' big: 0,',
- ' "1": "small",',
- ' small: 1',
- '};',
- 'this.TRec = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- '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.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');
- Add(' integer = longint;');
- Add(' TFlag = (big,small);');
- Add(' TFlags = set of TFlag;');
- Add(' TRec = record');
- Add(' i: integer;');
- Add(' end;');
- Add(' TArrInt = array of integer;');
- Add(' TArrRec = array of TRec;');
- Add(' TArrSet = array of TFlags;');
- Add(' TArrJSValue = array of jsvalue;');
- Add('var');
- Add(' ArrInt: tarrint;');
- Add(' ArrRec: tarrrec;');
- Add(' ArrSet: tarrset;');
- Add(' ArrJSValue: tarrjsvalue;');
- Add('begin');
- Add(' Insert(1,arrint,2);');
- Add(' Insert(arrint[3],arrint,4);');
- Add(' Insert(arrrec[5],arrrec,6);');
- Add(' Insert(arrset[7],arrset,7);');
- Add(' Insert(arrjsvalue[8],arrjsvalue,9);');
- Add(' Insert(10,arrjsvalue,11);');
- Add(' Delete(arrint,12,13);');
- Add(' Delete(arrrec,14,15);');
- Add(' Delete(arrset,17,18);');
- Add(' Delete(arrjsvalue,19,10);');
- ConvertProgram;
- CheckSource('TestArray_InsertDelete',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "big",',
- ' big: 0,',
- ' "1": "small",',
- ' small: 1',
- '};',
- 'this.TRec = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- 'this.ArrInt = [];',
- 'this.ArrRec = [];',
- 'this.ArrSet = [];',
- 'this.ArrJSValue = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.ArrInt.splice(2, 0, 1);',
- '$mod.ArrInt.splice(4, 0, $mod.ArrInt[3]);',
- '$mod.ArrRec.splice(6, 0, $mod.ArrRec[5]);',
- '$mod.ArrSet.splice(7, 0, $mod.ArrSet[7]);',
- '$mod.ArrJSValue.splice(9, 0, $mod.ArrJSValue[8]);',
- '$mod.ArrJSValue.splice(11, 0, 10);',
- '$mod.ArrInt.splice(12, 13);',
- '$mod.ArrRec.splice(14, 15);',
- '$mod.ArrSet.splice(17, 18);',
- '$mod.ArrJSValue.splice(19, 10);',
- '']));
- end;
- procedure TTestModule.TestArray_DynArrayConst;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' TArrInt = array of integer;',
- ' TArrStr = array of string;',
- 'const',
- ' Ints: TArrInt = (1,2,3);',
- ' Names: array of string = (''a'',''foo'');',
- ' Aliases: TarrStr = (''foo'',''b'');',
- ' OneInt: TArrInt = (7);',
- ' OneStr: array of integer = (7);',
- //' Chars: array of char = ''aoc'';',
- ' NameCount = low(Names)+high(Names)+length(Names);',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestArray_DynArrayConst',
- LinesToStr([ // statements
- 'this.Ints = [1, 2, 3];',
- 'this.Names = ["a", "foo"];',
- 'this.Aliases = ["foo", "b"];',
- 'this.OneInt = [7];',
- 'this.OneStr = [7];',
- 'this.NameCount = (0 + (rtl.length($mod.Names) - 1)) + rtl.length($mod.Names);',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastArrayToExternalArray;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TJSArray = class external name ''Array''');
- Add(' class function isArray(Value: JSValue) : boolean;');
- Add(' function concat() : TJSArray; varargs;');
- Add(' end;');
- Add('var');
- Add(' aObj: TJSArray;');
- Add(' a: array of longint;');
- Add('begin');
- Add(' if TJSArray.isArray(65) then ;');
- Add(' aObj:=TJSArray(a).concat(a);');
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastArrayToExternalArray',
- LinesToStr([ // statements
- 'this.aObj = null;',
- 'this.a = [];',
- '']),
- LinesToStr([ // $mod.$main
- 'if (Array.isArray(65)) ;',
- '$mod.aObj = $mod.a.concat($mod.a);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_TypeCastArrayFromExternalArray;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TArrStr = array of string;');
- Add(' TJSArray = class external name ''Array''');
- Add(' end;');
- Add('var');
- Add(' aObj: TJSArray;');
- Add(' a: TArrStr;');
- Add('begin');
- Add(' a:=TArrStr(aObj);');
- Add(' TArrStr(aObj)[1]:=TArrStr(aObj)[2];');
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastArrayFromExternalArray',
- LinesToStr([ // statements
- 'this.aObj = null;',
- 'this.a = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.a = $mod.aObj;',
- '$mod.aObj[1] = $mod.aObj[2];',
- '']));
- 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
- 'this.TRecA = function (s) {',
- ' if (s) {',
- ' this.Bold = s.Bold;',
- ' } else {',
- ' this.Bold = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.Bold === b.Bold;',
- ' };',
- '};',
- 'this.Rec = new $mod.TRecA();'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Rec.Bold = 123;'
- ]));
- end;
- procedure TTestModule.TestWithRecordDo;
- 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
- 'this.TRec = function (s) {',
- ' if (s) {',
- ' this.vI = s.vI;',
- ' } else {',
- ' this.vI = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.vI === b.vI;',
- ' };',
- '};',
- 'this.Int = 0;',
- 'this.r = new $mod.TRec();'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with1 = $mod.r;',
- '$mod.Int = $with1.vI;',
- 'var $with2 = $mod.r;',
- '$mod.Int = $with2.vI;',
- '$with2.vI = $mod.Int;'
- ]));
- end;
- procedure TTestModule.TestRecord_Assign;
- begin
- StartProgram(false);
- Add('type');
- Add(' TEnum = (red,green);');
- Add(' TEnums = set of TEnum;');
- Add(' TSmallRec = record');
- Add(' N: longint;');
- Add(' end;');
- Add(' TBigRec = record');
- Add(' Int: longint;');
- Add(' D: double;');
- Add(' Arr: array of longint;');
- Add(' Small: TSmallRec;');
- Add(' Enums: TEnums;');
- Add(' end;');
- Add('var');
- Add(' r, s: TBigRec;');
- Add('begin');
- Add(' r:=s;');
- ConvertProgram;
- CheckSource('TestRecord_Assign',
- LinesToStr([ // statements
- 'this.TEnum = {',
- ' "0": "red",',
- ' red: 0,',
- ' "1": "green",',
- ' green: 1',
- '};',
- 'this.TSmallRec = function (s) {',
- ' if(s){',
- ' this.N = s.N;',
- ' } else {',
- ' this.N = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.N === b.N;',
- ' };',
- '};',
- 'this.TBigRec = function (s) {',
- ' if(s){',
- ' this.Int = s.Int;',
- ' this.D = s.D;',
- ' this.Arr = s.Arr;',
- ' this.Small = new $mod.TSmallRec(s.Small);',
- ' this.Enums = rtl.refSet(s.Enums);',
- ' } else {',
- ' this.Int = 0;',
- ' this.D = 0.0;',
- ' this.Arr = [];',
- ' this.Small = new $mod.TSmallRec();',
- ' this.Enums = {};',
- ' };',
- ' this.$equal = function (b) {',
- ' return (this.Int === b.Int) && ((this.D === b.D) && ((this.Arr === b.Arr)',
- ' && (this.Small.$equal(b.Small) && rtl.eqSet(this.Enums, b.Enums))));',
- ' };',
- '};',
- 'this.r = new $mod.TBigRec();',
- 'this.s = new $mod.TBigRec();'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.r = new $mod.TBigRec($mod.s);',
- '']));
- end;
- procedure TTestModule.TestRecord_PassAsArgClone;
- begin
- StartProgram(false);
- Add('type');
- Add(' TRecA = record');
- Add(' Bold: longint;');
- Add(' end;');
- Add('procedure DoDefault(r: treca); begin end;');
- Add('procedure DoConst(const r: treca); begin end;');
- Add('var Rec: treca;');
- Add('begin');
- Add(' dodefault(rec);');
- Add(' doconst(rec);');
- ConvertProgram;
- CheckSource('TestRecord_PassAsArgClone',
- LinesToStr([ // statements
- 'this.TRecA = function (s) {',
- ' if (s) {',
- ' this.Bold = s.Bold;',
- ' } else {',
- ' this.Bold = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.Bold === b.Bold;',
- ' };',
- '};',
- 'this.DoDefault = function (r) {',
- '};',
- 'this.DoConst = function (r) {',
- '};',
- 'this.Rec = new $mod.TRecA();'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.DoDefault(new $mod.TRecA($mod.Rec));',
- '$mod.DoConst($mod.Rec);',
- '']));
- end;
- procedure TTestModule.TestRecord_AsParams;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TRecord = record');
- Add(' i: integer;');
- Add(' end;');
- Add('procedure DoIt(vG: TRecord; const vH: TRecord; var vI: TRecord);');
- Add('var vJ: TRecord;');
- 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: TRecord;');
- Add('begin');
- Add(' doit(i,i,i);');
- ConvertProgram;
- CheckSource('TestRecord_AsParams',
- LinesToStr([ // statements
- 'this.TRecord = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = new $mod.TRecord();',
- ' vG = new $mod.TRecord(vG);',
- ' vJ = new $mod.TRecord(vH);',
- ' vI.set(new $mod.TRecord(vI.get()));',
- ' $mod.DoIt(new $mod.TRecord(vG), vG, {',
- ' get: function () {',
- ' return vG;',
- ' },',
- ' set: function (v) {',
- ' vG = v;',
- ' }',
- ' });',
- ' $mod.DoIt(new $mod.TRecord(vH), vH, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- ' $mod.DoIt(new $mod.TRecord(vI.get()), vI.get(), vI);',
- ' $mod.DoIt(new $mod.TRecord(vJ), vJ, {',
- ' get: function () {',
- ' return vJ;',
- ' },',
- ' set: function (v) {',
- ' vJ = v;',
- ' }',
- ' });',
- '};',
- 'this.i = new $mod.TRecord();'
- ]),
- LinesToStr([
- '$mod.DoIt(new $mod.TRecord($mod.i),$mod.i,{',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- '});'
- ]));
- 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
- 'this.TRecord = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- 'this.DoIt = function (vG,vH,vI) {',
- ' var vJ = new $mod.TRecord();',
- ' $mod.DoIt(vJ.i, vJ.i, {',
- ' p: vJ,',
- ' get: function () {',
- ' return this.p.i;',
- ' },',
- ' set: function (v) {',
- ' this.p.i = v;',
- ' }',
- ' });',
- '};',
- 'this.r = new $mod.TRecord();'
- ]),
- 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
- 'this.TRecord = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- 'this.GetRec = function (vB) {',
- ' var Result = new $mod.TRecord();',
- ' 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
- 'this.TRecord = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- 'this.DoIt = function (vG,vH,vI) {',
- '};',
- 'this.r = new $mod.TRecord();'
- ]),
- LinesToStr([
- 'var $with1 = $mod.r;',
- '$mod.DoIt($with1.i,$with1.i,{',
- ' p: $with1,',
- ' 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',
- '};',
- 'this.TRecord = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' this.Event = s.Event;',
- ' this.f = rtl.refSet(s.f);',
- ' } else {',
- ' this.i = 0;',
- ' this.Event = null;',
- ' this.f = {};',
- ' };',
- ' this.$equal = function (b) {',
- ' return (this.i === b.i) && (rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f));',
- ' };',
- '};',
- 'this.TNested = function (s) {',
- ' if (s) {',
- ' this.r = new $mod.TRecord(s.r);',
- ' } else {',
- ' this.r = new $mod.TRecord();',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.r.$equal(b.r);',
- ' };',
- '};',
- 'this.b = false;',
- 'this.r = new $mod.TRecord();',
- 'this.s = new $mod.TRecord();'
- ]),
- LinesToStr([
- '$mod.b = $mod.r.$equal($mod.s);',
- '$mod.b = !$mod.r.$equal($mod.s);',
- '']));
- end;
- procedure TTestModule.TestRecord_TypeCastJSValueToRecord;
- begin
- StartProgram(false);
- Add('type');
- Add(' TRecord = record');
- Add(' i: longint;');
- Add(' end;');
- Add('var');
- Add(' Jv: jsvalue;');
- Add(' Rec: trecord;');
- Add('begin');
- Add(' rec:=trecord(jv);');
- ConvertProgram;
- CheckSource('TestRecord_TypeCastJSValueToRecord',
- LinesToStr([ // statements
- 'this.TRecord = function (s) {',
- ' if (s) {',
- ' this.i = s.i;',
- ' } else {',
- ' this.i = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.i === b.i;',
- ' };',
- '};',
- 'this.Jv = undefined;',
- 'this.Rec = new $mod.TRecord();'
- ]),
- LinesToStr([
- '$mod.Rec = new $mod.TRecord(rtl.getObject($mod.Jv));',
- '']));
- end;
- procedure TTestModule.TestClass_TObjectDefaultConstructor;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' public');
- Add(' constructor Create;');
- Add(' destructor Destroy;');
- Add(' end;');
- Add(' TBird = TObject;');
- Add('constructor tobject.create;');
- Add('begin end;');
- Add('destructor tobject.destroy;');
- Add('begin end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj:=tobject.create;');
- Add(' obj:=tbird.create;');
- Add(' obj.destroy;');
- ConvertProgram;
- CheckSource('TestClass_TObjectDefaultConstructor',
- LinesToStr([ // statements
- 'rtl.createClass($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(){',
- ' };',
- ' this.Destroy = function(){',
- ' };',
- '});',
- 'this.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.TObject.$create("Create");',
- '$mod.Obj = $mod.TObject.$create("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($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(Par){',
- ' };',
- '});',
- '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($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(){',
- ' };',
- '});',
- 'rtl.createClass($mod, "TTest", $mod.TObject, function () {',
- ' this.Create$1 = function (Par) {',
- ' };',
- '});',
- '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');
- Add(' TObject = class');
- Add(' public');
- Add(' vI: longint;');
- Add(' constructor Create(Par: longint);');
- Add(' end;');
- Add('constructor tobject.create(par: longint);');
- Add('begin');
- Add(' vi:=par+3');
- Add('end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj:=tobject.create(4);');
- Add(' obj.vi:=obj.VI+5;');
- ConvertProgram;
- CheckSource('TestClass_Var',
- LinesToStr([ // statements
- 'rtl.createClass($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' this.vI = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(Par){',
- ' this.vI = Par+3;',
- ' };',
- '});',
- '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($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' this.vI = 0;',
- ' this.Sub = null;',
- ' };',
- ' this.$final = function () {',
- ' this.Sub = undefined;',
- ' };',
- ' this.Create = function(){',
- ' };',
- ' 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($mod, "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();',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '$impl.TIntClass.DoGlob();',
- '']),
- LinesToStr([
- 'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
- ' this.Create$1 = function () {',
- ' $mod.TObject.Create.apply(this, arguments);',
- ' $mod.TObject.Create.call(this);',
- ' this.$class.DoGlob();',
- ' };',
- ' 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($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod,"TClassA",$mod.TObject,function(){',
- '});',
- 'rtl.createClass($mod,"TClassB",$mod.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_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($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});'
- ]),
- LinesToStr([ // this.$main
- ''
- ]));
- end;
- procedure TTestModule.TestClass_CallInherited_NoParams;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' procedure DoAbstract; virtual; abstract;');
- Add(' procedure DoVirtual; virtual;');
- Add(' procedure DoIt;');
- Add(' end;');
- Add(' TA = class');
- Add(' procedure doabstract; override;');
- Add(' procedure dovirtual; override;');
- Add(' procedure DoSome;');
- Add(' end;');
- Add('procedure tobject.dovirtual;');
- Add('begin');
- Add(' inherited; // call non existing ancestor -> ignore silently');
- Add('end;');
- Add('procedure tobject.doit;');
- Add('begin');
- Add('end;');
- Add('procedure ta.doabstract;');
- Add('begin');
- Add(' inherited dovirtual; // call TObject.DoVirtual');
- Add('end;');
- Add('procedure ta.dovirtual;');
- Add('begin');
- Add(' inherited; // call TObject.DoVirtual');
- Add(' inherited dovirtual; // call TObject.DoVirtual');
- Add(' inherited dovirtual(); // call TObject.DoVirtual');
- Add(' doit;');
- Add(' doit();');
- Add('end;');
- Add('procedure ta.dosome;');
- Add('begin');
- Add(' inherited; // call non existing ancestor method -> silently ignore');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestClass_CallInherited_NoParams',
- LinesToStr([ // statements
- 'rtl.createClass($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoVirtual = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
- ' this.DoAbstract = function () {',
- ' $mod.TObject.DoVirtual.call(this);',
- ' };',
- ' this.DoVirtual = function () {',
- ' $mod.TObject.DoVirtual.apply(this, arguments);',
- ' $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');
- Add(' TObject = class');
- Add(' procedure DoAbstract(pA: longint; pB: longint = 0); virtual; abstract;');
- Add(' procedure DoVirtual(pA: longint; pB: longint = 0); virtual;');
- Add(' procedure DoIt(pA: longint; pB: longint = 0);');
- Add(' procedure DoIt2(pA: longint = 1; pB: longint = 2);');
- Add(' end;');
- Add(' TClassA = class');
- Add(' procedure DoAbstract(pA: longint; pB: longint = 0); override;');
- Add(' procedure DoVirtual(pA: longint; pB: longint = 0); override;');
- Add(' end;');
- Add('procedure tobject.dovirtual(pa: longint; pb: longint = 0);');
- Add('begin');
- Add('end;');
- Add('procedure tobject.doit(pa: longint; pb: longint = 0);');
- Add('begin');
- Add('end;');
- Add('procedure tobject.doit2(pa: longint; pb: longint = 0);');
- Add('begin');
- Add('end;');
- Add('procedure tclassa.doabstract(pa: longint; pb: longint = 0);');
- Add('begin');
- Add(' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)');
- Add(' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)');
- Add('end;');
- Add('procedure tclassa.dovirtual(pa: longint; pb: longint = 0);');
- Add('begin');
- Add(' inherited; // call TObject.DoVirtual(pA,pB)');
- Add(' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)');
- Add(' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)');
- Add(' doit(pa,pb);');
- Add(' doit(pa);');
- Add(' doit2(pa);');
- Add(' doit2;');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestClass_CallInherited_WithParams',
- LinesToStr([ // statements
- 'rtl.createClass($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoVirtual = function (pA,pB) {',
- ' };',
- ' this.DoIt = function (pA,pB) {',
- ' };',
- ' this.DoIt2 = function (pA,pB) {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TClassA", $mod.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);',
- ' };',
- '});'
- ]),
- 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($mod,"TObject",null,function(){',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' };',
- ' this.CreateWithB = function (b) {',
- ' this.Create();',
- ' };',
- '});',
- 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
- ' this.Create = function () {',
- ' $mod.TObject.Create.apply(this, arguments);',
- ' $mod.TObject.Create.call(this);',
- ' $mod.TObject.CreateWithB.call(this, false);',
- ' };',
- ' this.CreateWithC = function (c) {',
- ' $mod.TObject.Create.call(this);',
- ' $mod.TObject.CreateWithB.call(this, true);',
- ' this.DoIt();',
- ' this.DoIt();',
- ' this.$class.DoSome();',
- ' };',
- ' 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;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' public');
- Add(' class var vI: longint;');
- Add(' class var Sub: TObject;');
- Add(' constructor Create;');
- Add(' class function GetIt(Par: longint): tobject;');
- Add(' end;');
- Add('constructor tobject.create;');
- Add('begin');
- Add(' vi:=vi+1;');
- Add(' Self.vi:=Self.vi+1;');
- Add('end;');
- Add('class function tobject.getit(par: longint): tobject;');
- Add('begin');
- Add(' vi:=vi+par;');
- Add(' Self.vi:=Self.vi+par;');
- Add(' Result:=self.sub;');
- Add('end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj:=tobject.create;');
- Add(' tobject.vi:=3;');
- Add(' if tobject.vi=4 then ;');
- Add(' tobject.sub:=nil;');
- Add(' obj.sub:=nil;');
- Add(' obj.sub.sub:=nil;');
- ConvertProgram;
- CheckSource('TestClass_ClassVar',
- LinesToStr([ // statements
- 'rtl.createClass($mod,"TObject",null,function(){',
- ' this.vI = 0;',
- ' this.Sub = null;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(){',
- ' this.$class.vI = this.vI+1;',
- ' this.$class.vI = this.vI+1;',
- ' };',
- ' this.GetIt = function(Par){',
- ' var Result = null;',
- ' this.vI = this.vI + Par;',
- ' this.vI = this.vI + Par;',
- ' Result = this.Sub;',
- ' 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.Obj.$class.Sub=null;',
- '$mod.Obj.Sub.$class.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($mod,"TObject",null,function(){',
- ' this.vI = 0;',
- ' this.Sub = null;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function(){',
- ' this.$class.Sub = this.$class.GetIt(3);',
- ' this.$class.vI = this.GetMore(4);',
- ' this.$class.Sub = this.$class.GetIt(5);',
- ' this.$class.vI = this.GetMore(6);',
- ' };',
- ' this.GetMore = function(Par){',
- ' var Result = 0;',
- ' this.$class.Sub = this.$class.GetIt(11);',
- ' this.$class.vI = this.GetMore(12);',
- ' this.$class.Sub = this.$class.GetIt(13);',
- ' this.$class.vI = this.GetMore(14);',
- ' return Result;',
- ' };',
- ' this.GetIt = function(Par){',
- ' var Result = null;',
- ' this.Sub = this.GetIt(21);',
- ' this.vI = this.Sub.GetMore(22);',
- ' this.Sub = this.GetIt(23);',
- ' this.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.Obj.Sub.$class.GetIt(8).$class.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_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($mod, "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');
- Add(' TObject = class');
- Add(' class var Fx: longint;');
- Add(' class var Fy: longint;');
- Add(' class function GetInt: longint;');
- Add(' class procedure SetInt(Value: longint);');
- Add(' class procedure DoIt;');
- Add(' class property IntA: longint read Fx write Fy;');
- Add(' class property IntB: longint read GetInt write SetInt;');
- Add(' end;');
- Add('class function tobject.getint: longint;');
- Add('begin');
- Add(' result:=fx;');
- Add('end;');
- Add('class procedure tobject.setint(value: longint);');
- Add('begin');
- Add('end;');
- Add('class 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(' tobject.inta:=tobject.inta+1;');
- Add(' if tobject.intb=2 then;');
- Add(' tobject.intb:=tobject.intb+2;');
- Add(' tobject.setint(tobject.inta);');
- 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_ClassMethod',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "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) {',
- ' };',
- ' 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.TObject.Fy = $mod.TObject.Fx + 1;',
- 'if ($mod.TObject.GetInt() === 2);',
- '$mod.TObject.SetInt($mod.TObject.GetInt() + 2);',
- '$mod.TObject.SetInt($mod.TObject.Fx);',
- '$mod.Obj.$class.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);'
- ]));
- end;
- procedure TTestModule.TestClass_Property_Indexed;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' FItems: array of longint;');
- Add(' function GetItems(Index: longint): longint;');
- Add(' procedure SetItems(Index: longint; Value: longint);');
- Add(' procedure DoIt;');
- Add(' property Items[Index: longint]: longint read getitems write setitems;');
- Add(' end;');
- Add('function tobject.getitems(index: longint): longint;');
- Add('begin');
- Add(' Result:=fitems[index];');
- Add('end;');
- Add('procedure tobject.setitems(index: longint; value: longint);');
- Add('begin');
- Add(' fitems[index]:=value;');
- Add('end;');
- Add('procedure tobject.doit;');
- Add('begin');
- Add(' items[1]:=2;');
- Add(' items[3]:=items[4];');
- Add(' self.items[5]:=self.items[6];');
- Add(' items[items[7]]:=items[items[8]];');
- Add('end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj.Items[11]:=obj.Items[12];');
- ConvertProgram;
- CheckSource('TestClass_Property_Indexed',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "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($mod, "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(' 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('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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FItems = [];',
- ' };',
- ' this.$final = function () {',
- ' this.FItems = undefined;',
- ' };',
- ' this.GetItems = function () {',
- ' var Result = [];',
- ' Result = this.FItems;',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Value) {',
- ' this.FItems = Value;',
- ' this.FItems = [];',
- ' this.SetItems([]);',
- ' this.SetItems(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.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');
- Add(' TArray = array of longint;');
- Add(' TObject = class');
- Add(' FItems: TArray;');
- Add(' function GetItems(Index: longint): longint;');
- Add(' procedure SetItems(Index, Value: longint);');
- Add(' property Items[Index: longint]: longint read getitems write setitems; default;');
- Add(' end;');
- Add('function tobject.getitems(index: longint): longint;');
- Add('begin');
- Add('end;');
- Add('procedure tobject.setitems(index, value: longint);');
- Add('begin');
- Add(' Self[1]:=2;');
- Add(' Self[3]:=Self[index];');
- Add(' Self[index]:=Self[Self[value]];');
- Add(' Self[Self[4]]:=value;');
- Add('end;');
- Add('var Obj: tobject;');
- Add('begin');
- Add(' obj[11]:=12;');
- Add(' obj[13]:=obj[14];');
- Add(' obj[obj[15]]:=obj[obj[15]];');
- ConvertProgram;
- CheckSource('TestClass_PropertyDefault',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FItems = [];',
- ' };',
- ' this.$final = function () {',
- ' this.FItems = undefined;',
- ' };',
- ' 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.Obj = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj.SetItems(11, 12);',
- '$mod.Obj.SetItems(13, $mod.Obj.GetItems(14));',
- '$mod.Obj.SetItems($mod.Obj.GetItems(15), $mod.Obj.GetItems($mod.Obj.GetItems(15)));'
- ]));
- 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FItem = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TCar", $mod.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_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($mod, "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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.aBool = false;',
- ' this.Arr = [];',
- ' };',
- ' this.$final = function () {',
- ' this.Arr = undefined;',
- ' };',
- ' this.Create = function () {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.b = false;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with1 = $mod.TObject.$create("Create");',
- '$mod.b = $with1.aBool;',
- '$with1.aBool = $mod.b;',
- '$mod.b = $with1.Arr[1];',
- '$with1.Arr[2] = $mod.b;',
- 'var $with2 = $mod.TObject;',
- '$mod.Obj = $with2.$create("Create");',
- 'var $with3 = $mod.Obj;',
- '$with3.Create();',
- '$mod.b = $with3.aBool;',
- '$with3.aBool = $mod.b;',
- '$mod.b = $with3.Arr[3];',
- '$with3.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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FInt = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' };',
- ' this.GetSize = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Value) {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with1 = $mod.TObject.$create("Create");',
- '$mod.i = $with1.FInt;',
- '$with1.FInt = $mod.i;',
- '$mod.i = $with1.GetSize();',
- '$with1.SetSize($mod.i);',
- 'var $with2 = $mod.Obj;',
- '$mod.i = $with2.FInt;',
- '$with2.FInt = $mod.i;',
- '$mod.i = $with2.GetSize();',
- '$with2.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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' };',
- ' this.GetItems = function (Index) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetItems = function (Index, Value) {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with1 = $mod.TObject.$create("Create");',
- '$mod.i = $with1.GetItems(1);',
- '$with1.SetItems(2, $mod.i);',
- 'var $with2 = $mod.Obj;',
- '$mod.i = $with2.GetItems(3);',
- '$with2.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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' };',
- ' this.GetSize = function () {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- ' this.SetSize = function (Value) {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.i = 0;'
- ]),
- LinesToStr([ // $mod.$main
- 'var $with1 = $mod.TObject.$create("Create");',
- '$mod.i = $with1.GetSize();',
- '$mod.i = $with1.GetSize();',
- '$with1.SetSize($mod.i);',
- 'var $with2 = $mod.Obj;',
- '$mod.i = $with2.GetSize();',
- '$mod.i = $with2.GetSize();',
- '$with2.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]);');
- ConvertProgram;
- CheckSource('TestClass_TypeCast',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Next = null;',
- ' };',
- ' this.$final = function () {',
- ' this.Next = undefined;',
- ' };',
- ' this.Create = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TControl", $mod.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];',
- '']));
- 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($mod, "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($mod, "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($mod, "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($mod, "TCar", $mod.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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function (vA) {',
- ' this.Create(1);',
- ' this.Create$1(1,2);',
- ' };',
- ' this.Create$1 = function (vA, vB) {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TCar", $mod.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);',
- ' };',
- ' this.Create$3 = function (vA, vB) {',
- ' };',
- '});',
- '']),
- 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TBird", $mod.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($mod, "TEagle", $mod.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_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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Some = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.Some$1 = "";',
- ' };',
- '});',
- 'rtl.createClass($mod, "TCar", $mod.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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function (Msg) {',
- ' };',
- '});',
- 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
- '});',
- 'rtl.createClass($mod, "EConvertError", $mod.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($mod, "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 $with1 = $impl.Obj;',
- '$with1.$DoIntern();',
- '$with1.$DoIntern();',
- '$with1.$DoIntern2();',
- '$with1.$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'';',
- ' end;',
- '']),
- LinesToStr([
- '']));
- StartUnit(true);
- Add('interface');
- Add('uses unit2;');
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TCar = class(tobject)');
- Add(' public');
- Add(' Intern2: longint external name ''$Intern2'';');
- Add(' procedure DoIt;');
- Add(' end;');
- Add('implementation');
- Add('procedure tcar.doit;');
- Add('begin');
- Add(' Intern:=Intern+1;');
- Add(' Intern2:=Intern2+2;');
- Add('end;');
- Add('var Obj: TCar;');
- Add('begin');
- Add(' obj.intern:=obj.intern+1;');
- Add(' obj.intern2:=obj.intern2+2;');
- Add(' with obj do begin');
- Add(' intern:=intern+1;');
- Add(' intern2:=intern2+2;');
- Add(' end;');
- ConvertUnit;
- CheckSource('TestClass_ExternalVar',
- LinesToStr([
- 'var $impl = $mod.$impl;',
- 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
- ' this.DoIt = function () {',
- ' this.$Intern = this.$Intern + 1;',
- ' this.$Intern2 = this.$Intern2 + 2;',
- ' };',
- ' });',
- '']),
- LinesToStr([
- '$impl.Obj.$Intern = $impl.Obj.$Intern + 1;',
- '$impl.Obj.$Intern2 = $impl.Obj.$Intern2 + 2;',
- 'var $with1 = $impl.Obj;',
- '$with1.$Intern = $with1.$Intern + 1;',
- '$with1.$Intern2 = $with1.$Intern2 + 2;',
- '']),
- LinesToStr([ // implementation
- '$impl.Obj = null;',
- '']));
- end;
- procedure TTestModule.TestClass_Const;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TClass = class of TObject;');
- Add(' TObject = class');
- Add(' public');
- Add(' const cI: integer = 3;');
- Add(' procedure DoIt;');
- Add(' class procedure DoMore;');
- Add(' end;');
- Add('implementation');
- Add('procedure tobject.doit;');
- Add('begin');
- Add(' if cI=4 then;');
- Add(' if 5=cI then;');
- Add(' if Self.cI=6 then;');
- Add(' if 7=Self.cI then;');
- Add(' with Self do begin');
- Add(' if cI=11 then;');
- Add(' if 12=cI then;');
- Add(' end;');
- Add('end;');
- Add('class procedure tobject.domore;');
- Add('begin');
- Add(' if cI=8 then;');
- Add(' if Self.cI=9 then;');
- Add(' if 10=cI then;');
- Add(' if 11=Self.cI then;');
- Add(' with Self do begin');
- Add(' if cI=13 then;');
- Add(' if 14=cI then;');
- Add(' end;');
- Add('end;');
- Add('var');
- Add(' Obj: TObject;');
- Add(' Cla: TClass;');
- Add('begin');
- Add(' if TObject.cI=21 then ;');
- Add(' if Obj.cI=22 then ;');
- Add(' if Cla.cI=23 then ;');
- Add(' with obj do if ci=24 then;');
- Add(' with TObject do if ci=25 then;');
- Add(' with Cla do if ci=26 then;');
- ConvertProgram;
- CheckSource('TestClass_Const',
- LinesToStr([
- 'rtl.createClass($mod, "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 $with1 = $mod.Obj;',
- 'if ($with1.cI === 24) ;',
- 'var $with2 = $mod.TObject;',
- 'if ($with2.cI === 25) ;',
- 'var $with3 = $mod.Cla;',
- 'if ($with3.cI === 26) ;',
- '']));
- 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_NestedSelf;
- 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_NestedSelf',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "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;',
- ' Self.$class.State = Self.State + 4;',
- ' Self.$class.State = Self.State + 5;',
- ' $mod.TObject.State = $mod.TObject.State + 6;',
- ' Self.SetSize(Self.GetSize() + 7);',
- ' Self.SetSize(Self.GetSize() + 8);',
- ' };',
- ' Sub();',
- ' Self.Key = Self.Key + 12;',
- ' Self.Key = Self.Key + 13;',
- ' Self.$class.State = Self.State + 14;',
- ' Self.$class.State = Self.State + 15;',
- ' $mod.TObject.State = $mod.TObject.State + 16;',
- ' Self.SetSize(Self.GetSize() + 17);',
- ' Self.SetSize(Self.GetSize() + 18);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_NestedClassSelf;
- 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_NestedClassSelf',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.State = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' var Self = this;',
- ' function Sub() {',
- ' Self.State = Self.State + 2;',
- ' Self.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();',
- ' Self.State = Self.State + 12;',
- ' Self.State = Self.State + 13;',
- ' $mod.TObject.State = $mod.TObject.State + 14;',
- ' Self.SetSize(Self.GetSize() + 15);',
- ' Self.SetSize(Self.GetSize() + 16);',
- ' $mod.TObject.SetSize($mod.TObject.GetSize() + 17);',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_NestedCallInherited;
- 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_NestedCallInherited',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function (k) {',
- ' var Result = 0;',
- ' return Result;',
- ' };',
- '});',
- 'rtl.createClass($mod, "TBird", $mod.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(Self, arguments);',
- ' $mod.TObject.DoIt.call(Self, true);',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestClass_TObjectFree;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' Obj: tobject;',
- ' procedure Free;',
- ' end;',
- 'procedure tobject.free;',
- 'begin',
- '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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.Obj = null;',
- ' };',
- ' this.$final = function () {',
- ' this.Obj = undefined;',
- ' };',
- ' this.Free = function () {',
- ' };',
- '});',
- '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_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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' };',
- ' this.Free = function () {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- 'var $with1 = $mod.TObject.$create("Create");',
- '$with1=rtl.freeLoc($with1);',
- '']));
- 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($mod, "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.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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.Create = function () {',
- ' };',
- '});',
- 'this.Obj = null;',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.C.$create("Create");',
- 'var $with1 = $mod.C;',
- '$mod.Obj = $with1.$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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' };',
- '});',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.C.DoIt();',
- 'var $with1 = $mod.C;',
- '$with1.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($mod, "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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TCar", $mod.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($mod, "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($mod, "TObject", null, function () {',
- ' this.id = 0;',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.C = null;'
- ]),
- LinesToStr([ // $mod.$main
- '$mod.C.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($mod, "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');
- Add(' TObject = class');
- Add(' class var FA: longint;');
- Add(' class function GetA: longint;');
- Add(' class procedure SetA(Value: longint);');
- Add(' class property pA: longint read fa write fa;');
- Add(' class property pB: longint read geta write seta;');
- Add(' end;');
- Add(' TObjectClass = class of tobject;');
- Add('class function tobject.geta: longint; begin end;');
- Add('class procedure tobject.seta(value: longint); begin end;');
- Add('var');
- Add(' b: boolean;');
- Add(' Obj: tobject;');
- Add(' Cla: tobjectclass;');
- Add('begin');
- Add(' obj.pa:=obj.pa;');
- Add(' obj.pb:=obj.pb;');
- Add(' b:=obj.pa=4;');
- Add(' b:=obj.pb=obj.pb;');
- Add(' b:=5=obj.pa;');
- Add(' cla.pa:=6;');
- Add(' cla.pa:=cla.pa;');
- Add(' cla.pb:=cla.pb;');
- Add(' b:=cla.pa=7;');
- Add(' b:=cla.pb=cla.pb;');
- Add(' b:=8=cla.pa;');
- Add(' tobject.pa:=9;');
- Add(' tobject.pb:=tobject.pb;');
- Add(' b:=tobject.pa=10;');
- Add(' b:=11=tobject.pa;');
- ConvertProgram;
- CheckSource('TestClassOf_ClassProperty',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "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.Obj.$class.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.Cla.FA = 6;',
- '$mod.Cla.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($mod, "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;',
- ' this.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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.DoIt = function () {',
- ' this.DoIt();',
- ' this.DoIt$1();',
- ' };',
- '});',
- 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
- ' this.DoIt$1 = function () {',
- ' this.DoIt();',
- ' this.DoIt$1();',
- ' this.DoIt$2();',
- ' };',
- '});',
- 'rtl.createClass($mod, "TCar", $mod.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($mod, "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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "THawk", $mod.TObject, function () {',
- '});',
- 'this.Hawk = $mod.THawk;',
- 'this.DefaultBirdClasses = [$mod.TObject, $mod.THawk];',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestNestedClass_Fail;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class',
- ' type TNested = longint;',
- ' end;',
- 'begin']);
- SetExpectedPasResolverError('not yet implemented: TNested:TPasAliasType [20170608232534] nested types',
- nNotYetImplemented);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_Var;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtObj''');
- Add(' Id: longint external name ''$Id'';');
- Add(' B: longint;');
- Add(' end;');
- Add('var Obj: TExtA;');
- Add('begin');
- Add(' obj.id:=obj.id+1;');
- Add(' 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_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}');
- Add('type');
- Add(' TExtA = class external name ''ExtObj''');
- Add(' procedure DoIt(Id: longint = 1); external name ''$Execute'';');
- Add(' procedure DoSome(Id: longint = 1);');
- Add(' end;');
- Add('var Obj: texta;');
- Add('begin');
- Add(' obj.doit;');
- Add(' obj.doit();');
- Add(' obj.doit(2);');
- Add(' with obj do begin');
- Add(' doit;');
- Add(' doit();');
- Add(' doit(3);');
- Add(' 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 $with1 = $mod.Obj;',
- '$with1.$Execute(1);',
- '$with1.$Execute(1);',
- '$with1.$Execute(3);',
- '']));
- end;
- procedure TTestModule.TestExternalClass_NonExternalOverride;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtObjA''');
- Add(' procedure ProcA; virtual;');
- Add(' procedure ProcB; virtual;');
- Add(' end;');
- Add(' TExtB = class external name ''ExtObjB'' (TExtA)');
- Add(' end;');
- Add(' TExtC = class (TExtB)');
- Add(' procedure ProcA; override;');
- Add(' end;');
- Add('procedure TExtC.ProcA;');
- Add('begin');
- Add(' ProcA;');
- Add(' Self.ProcA;');
- Add(' ProcB;');
- Add(' Self.ProcB;');
- Add('end;');
- Add('var');
- Add(' A: texta;');
- Add(' B: textb;');
- Add(' C: textc;');
- Add('begin');
- Add(' a.proca;');
- Add(' b.proca;');
- Add(' c.proca;');
- ConvertProgram;
- CheckSource('TestExternalClass_NonExternalOverride',
- LinesToStr([ // statements
- 'rtl.createClassExt($mod, "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_Property;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' function getYear: longint;');
- Add(' procedure setYear(Value: longint);');
- Add(' property Year: longint read getyear write setyear;');
- Add(' end;');
- Add(' TExtB = class (TExtA)');
- Add(' procedure OtherSetYear(Value: longint);');
- Add(' property year write othersetyear;');
- Add(' end;');
- Add('procedure textb.othersetyear(value: longint);');
- Add('begin');
- Add(' setYear(Value+4);');
- Add('end;');
- Add('var');
- Add(' A: texta;');
- Add(' B: textb;');
- Add('begin');
- Add(' a.year:=a.year+1;');
- Add(' b.year:=b.year+2;');
- ConvertProgram;
- CheckSource('TestExternalClass_NonExternalOverride',
- LinesToStr([ // statements
- 'rtl.createClassExt($mod, "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_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($mod, "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($mod, "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}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- 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(' end;');
- Add(' TExtCClass = class of TExtC;');
- Add('var');
- Add(' A: texta; ClA: TExtAClass;');
- Add(' B: textb; ClB: TExtBClass;');
- Add(' C: textc; ClC: TExtCClass;');
- Add('begin');
- Add(' if a is textb then ;');
- Add(' if a is textc then ;');
- Add(' if b is textc then ;');
- Add(' if cla is textb then ;');
- Add(' if cla is textc then ;');
- Add(' if clb is textc then ;');
- ConvertProgram;
- CheckSource('TestExternalClass_Is',
- LinesToStr([ // statements
- 'rtl.createClassExt($mod, "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)) ;',
- '']));
- 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($mod, "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}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' constructor New;');
- Add(' constructor New(i: longint; j: longint = 2);');
- Add(' end;');
- Add('var');
- Add(' A: texta;');
- Add('begin');
- Add(' a:=texta.new;');
- Add(' a:=texta.new();');
- Add(' a:=texta.new(1);');
- Add(' with texta do begin');
- Add(' a:=new;');
- Add(' a:=new();');
- Add(' a:=new(2);');
- Add(' end;');
- Add(' a:=test1.texta.new;');
- Add(' a:=test1.texta.new();');
- Add(' 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(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(' 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();');
- 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 $with1 = $mod.C;',
- '$mod.A = new $with1();',
- '$mod.A = new $with1();',
- '$mod.A = new $mod.C();',
- '$mod.A = new $mod.C();',
- '']));
- end;
- procedure TTestModule.TestExternalClass_FuncClassOf_New;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtAClass = class of TExtA;');
- Add(' TExtA = class external name ''ExtA''');
- Add(' constructor New;');
- Add(' end;');
- Add('function GetCreator: TExtAClass;');
- Add('begin');
- Add(' Result:=TExtA;');
- Add('end;');
- Add('var');
- Add(' A: texta;');
- Add('begin');
- Add(' a:=getcreator.new;');
- Add(' a:=getcreator().new;');
- Add(' a:=getcreator().new();');
- Add(' a:=getcreator.new();');
- Add(' with getcreator do begin');
- Add(' a:=new;');
- Add(' a:=new();');
- Add(' 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 $with1 = $mod.GetCreator();',
- '$mod.A = new $with1();',
- '$mod.A = new $with1();',
- '']));
- 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 = 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($mod, "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($mod, "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($mod, "TMyB", ExtA, "NewInstance", function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.NewInstance = function (fnname, paramarray) {',
- ' var Result = null;',
- ' return Result;',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestExternalClass_NewInstance_NonVirtualFail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' end;');
- Add(' TMyB = class(TExtA)');
- Add(' protected');
- Add(' class function NewInstance(fnname: string; const paramarray): TMyB;');
- Add(' end;');
- Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
- Add('begin end;');
- Add('begin');
- SetExpectedPasResolverError(sNewInstanceFunctionMustBeVirtual,nNewInstanceFunctionMustBeVirtual);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_NewInstance_FirstParamNotString_Fail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' end;');
- Add(' TMyB = class(TExtA)');
- Add(' protected');
- Add(' class function NewInstance(fnname: longint; const paramarray): TMyB; virtual;');
- Add(' end;');
- Add('class function TMyB.NewInstance(fnname: longint; const paramarray): TMyB;');
- Add('begin end;');
- Add('begin');
- SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Longint", expected "String"',
- nIncompatibleTypeArgNo);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_NewInstance_SecondParamTyped_Fail;
- begin
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TExtA = class external name ''ExtA''');
- Add(' end;');
- Add(' TMyB = class(TExtA)');
- Add(' protected');
- Add(' class function NewInstance(fnname: string; const paramarray: string): TMyB; virtual;');
- Add(' end;');
- Add('class function TMyB.NewInstance(fnname: string; const paramarray: string): TMyB;');
- Add('begin end;');
- Add('begin');
- SetExpectedPasResolverError('Incompatible type arg no. 2: Got "type", expected "untyped"',
- nIncompatibleTypeArgNo);
- ConvertProgram;
- end;
- procedure TTestModule.TestExternalClass_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($mod, "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}');
- Add('type');
- Add(' TObject = class');
- Add(' end;');
- Add(' TChild = class');
- Add(' end;');
- Add(' TExtRootA = class external name ''ExtRootA''');
- Add(' end;');
- Add(' TExtChildA = class external name ''ExtChildA''(TExtRootA)');
- Add(' end;');
- Add(' TExtRootB = class external name ''ExtRootB''');
- Add(' end;');
- Add(' TExtChildB = class external name ''ExtChildB''(TExtRootB)');
- Add(' end;');
- Add('var');
- Add(' Obj: TObject;');
- Add(' Child: TChild;');
- Add(' RootA: TExtRootA;');
- Add(' ChildA: TExtChildA;');
- Add(' RootB: TExtRootB;');
- Add(' ChildB: TExtChildB;');
- Add('begin');
- Add(' obj:=tobject(roota);');
- Add(' obj:=tobject(childa);');
- Add(' child:=tchild(tobject(roota));');
- Add(' roota:=textroota(obj);');
- Add(' roota:=textroota(child);');
- Add(' roota:=textroota(rootb);');
- Add(' roota:=textroota(childb);');
- Add(' childa:=textchilda(textroota(obj));');
- ConvertProgram;
- CheckSource('TestExternalClass_TypeCastToRootClass',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
- '});',
- 'this.Obj = null;',
- 'this.Child = null;',
- 'this.RootA = null;',
- 'this.ChildA = null;',
- 'this.RootB = null;',
- 'this.ChildB = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Obj = $mod.RootA;',
- '$mod.Obj = $mod.ChildA;',
- '$mod.Child = $mod.RootA;',
- '$mod.RootA = $mod.Obj;',
- '$mod.RootA = $mod.Child;',
- '$mod.RootA = $mod.RootB;',
- '$mod.RootA = $mod.ChildB;',
- '$mod.ChildA = $mod.Obj;',
- '']));
- 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_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}');
- 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('procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);');
- Add('begin end;');
- Add('var');
- Add(' Arr: tjsarray;');
- Add(' s: string;');
- Add(' i: longint;');
- Add(' v: jsvalue;');
- Add('begin');
- Add(' v:=arr[0];');
- Add(' v:=arr.items[1];');
- Add(' arr[2]:=s;');
- Add(' arr.items[3]:=s;');
- Add(' arr[4]:=i;');
- Add(' arr[5]:=arr[6];');
- Add(' arr.items[7]:=arr.items[8];');
- Add(' with arr do items[9]:=items[10];');
- Add(' doit(arr[7],arr[8],arr[9],arr[10]);');
- 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 $with1 = $mod.Arr;',
- '$with1[9] = $with1[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;',
- ' }',
- '});',
- '']));
- 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 $with1 = $mod.Arr;',
- '$mod.v = $with1[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 $with1 = $mod.Arr;',
- '$with1[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 $with1 = $mod.Arr;',
- '$with1[5] = $mod.i;',
- 'var $with2 = $mod.Arr;',
- '$with2[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[Math.floor($mod.v)] = $mod.Arr[$mod.IntArr[0]];',
- '$mod.Arr[$mod.IntArr[1]] = $mod.Arr[$mod.IntArr[2]];',
- '']));
- end;
- procedure TTestModule.TestClassInterface_Ignore;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch ignoreinterfaces}',
- 'type',
- ' TGUID = record end;',
- ' IUnknown = interface;',
- ' IUnknown = interface',
- ' [''{00000000-0000-0000-C000-000000000046}'']',
- ' function QueryInterface(const iid : tguid;out obj) : longint;',
- ' function _AddRef : longint; cdecl;',
- ' function _Release : longint; stdcall;',
- ' end;',
- ' IInterface = IUnknown;',
- ' TObject = class',
- ' ClassName: string;',
- ' end;',
- ' TInterfacedObject = class(TObject,IUnknown)',
- ' RefCount : longint;',
- ' end;',
- 'var i: TInterfacedObject;',
- 'begin',
- ' i.ClassName:=''a'';',
- ' i.RefCount:=3;',
- '']);
- ConvertProgram;
- CheckSource('TestClassInterface_Ignore',
- LinesToStr([ // statements
- 'this.TGUID = function (s) {',
- '};',
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.ClassName = "";',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TInterfacedObject", $mod.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.RefCount = 0;',
- ' };',
- '});',
- 'this.i = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.i.ClassName = "a";',
- '$mod.i.RefCount = 3;',
- '']));
- end;
- procedure TTestModule.TestProcType;
- begin
- StartProgram(false);
- Add('type');
- Add(' TProcInt = procedure(vI: longint = 1);');
- Add('procedure DoIt(vJ: longint);');
- Add('begin end;');
- Add('var');
- Add(' b: boolean;');
- Add(' vP, vQ: tprocint;');
- Add('begin');
- Add(' vp:=nil;');
- Add(' vp:=vp;');
- Add(' vp:=@doit;');
- Add(' vp;');
- Add(' vp();');
- Add(' vp(2);');
- Add(' b:=vp=nil;');
- Add(' b:=nil=vp;');
- Add(' b:=vp=vq;');
- Add(' b:=vp=@doit;');
- Add(' b:=@doit=vp;');
- Add(' b:=vp<>nil;');
- Add(' b:=nil<>vp;');
- Add(' b:=vp<>vq;');
- Add(' b:=vp<>@doit;');
- Add(' b:=@doit<>vp;');
- Add(' b:=Assigned(vp);');
- Add(' 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_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($mod, "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}');
- 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_MethodDelphi',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "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($mod, "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($mod, "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($mod, "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 $with1 = $mod.Obj;',
- '$with1.FOnFoo = null;',
- '$with1.FOnFoo = null;',
- '$with1.SetFoo(null);',
- '$with1.FOnFoo = $with1.FOnFoo;',
- '$with1.FOnFoo = $with1.FOnFoo;',
- '$with1.SetFoo($with1.GetFoo());',
- '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
- '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
- '$with1.SetFoo(rtl.createCallback($with1, "DoIt"));',
- '$with1.FOnFoo(1);',
- '$with1.FOnFoo(1);',
- '$with1.GetFoo();',
- '$with1.FOnFoo(1);',
- '$with1.FOnFoo(1);',
- '$with1.GetFoo()(1);',
- '$mod.b = $with1.FOnFoo === null;',
- '$mod.b = $with1.FOnFoo === null;',
- '$mod.b = $with1.GetFoo() === null;',
- '$mod.b = $with1.FOnFoo !== null;',
- '$mod.b = $with1.FOnFoo !== null;',
- '$mod.b = $with1.GetFoo() !== null;',
- '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
- '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
- '$mod.b = rtl.eqCallback($with1.GetFoo(), $mod.vP);',
- '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
- '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
- '$mod.b = rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
- '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
- '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
- '$mod.b = !rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
- '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
- '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
- '$mod.b = rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
- '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
- '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
- '$mod.b = !rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
- '$mod.b = $with1.FOnFoo !== null;',
- '$mod.b = $with1.FOnFoo !== null;',
- '$mod.b = $with1.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($mod, "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($mod, "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.TestPointer;
- begin
- StartProgram(false);
- Add('type');
- Add(' TObject = class end;');
- Add(' TClass = class of TObject;');
- Add(' TArrInt = array of longint;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' Obj: tobject;');
- Add(' C: tclass;');
- Add(' a: tarrint;');
- Add(' p: Pointer;');
- Add('begin');
- Add(' p:=p;');
- Add(' p:=nil;');
- Add(' if p=nil then;');
- Add(' if nil=p then;');
- Add(' if Assigned(p) then;');
- Add(' p:=Pointer(v);');
- Add(' p:=obj;');
- Add(' p:=c;');
- Add(' p:=a;');
- Add(' p:=tobject;');
- Add(' obj:=TObject(p);');
- Add(' c:=TClass(p);');
- Add(' a:=TArrInt(p);');
- ConvertProgram;
- CheckSource('TestPointer',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.v = undefined;',
- 'this.Obj = null;',
- 'this.C = null;',
- 'this.a = [];',
- 'this.p = null;',
- '']),
- 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;',
- '']));
- 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($mod, "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_ArrayParamsFail;
- begin
- StartProgram(false);
- Add('var');
- Add(' p: Pointer;');
- Add('begin');
- Add(' p:=p[1];');
- SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
- 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.TestJSValue_AssignToJSValue;
- begin
- StartProgram(false);
- Add('var');
- Add(' v: jsvalue;');
- Add(' i: longint;');
- Add(' s: string;');
- Add(' b: boolean;');
- Add(' d: double;');
- Add(' p: pointer;');
- Add('begin');
- Add(' v:=v;');
- Add(' v:=1;');
- Add(' v:=i;');
- Add(' v:='''';');
- Add(' v:=''c'';');
- Add(' v:=''foo'';');
- Add(' v:=s;');
- Add(' v:=false;');
- Add(' v:=true;');
- Add(' v:=b;');
- Add(' v:=0.1;');
- Add(' v:=d;');
- Add(' v:=nil;');
- Add(' v:=p;');
- ConvertProgram;
- CheckSource('TestJSValue_AssignToJSValue',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.i = 0;',
- 'this.s = "";',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.v;',
- '$mod.v = 1;',
- '$mod.v = $mod.i;',
- '$mod.v = "";',
- '$mod.v = "c";',
- '$mod.v = "foo";',
- '$mod.v = $mod.s;',
- '$mod.v = false;',
- '$mod.v = true;',
- '$mod.v = $mod.b;',
- '$mod.v = 0.1;',
- '$mod.v = $mod.d;',
- '$mod.v = null;',
- '$mod.v = $mod.p;',
- '']));
- end;
- procedure TTestModule.TestJSValue_TypeCastToBaseType;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TYesNo = boolean;');
- Add(' TFloat = double;');
- Add(' TCaption = string;');
- Add(' TChar = char;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' i: integer;');
- Add(' s: TCaption;');
- Add(' b: TYesNo;');
- Add(' d: TFloat;');
- Add(' c: char;');
- Add('begin');
- Add(' i:=longint(v);');
- Add(' i:=integer(v);');
- Add(' s:=string(v);');
- Add(' s:=TCaption(v);');
- Add(' b:=boolean(v);');
- Add(' b:=TYesNo(v);');
- Add(' d:=double(v);');
- Add(' d:=TFloat(v);');
- Add(' c:=char(v);');
- Add(' c:=TChar(v);');
- ConvertProgram;
- CheckSource('TestJSValue_TypeCastToBaseType',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.i = 0;',
- 'this.s = "";',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.c = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.i = Math.floor($mod.v);',
- '$mod.i = Math.floor($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_Equal;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TYesNo = boolean;');
- Add(' TFloat = double;');
- Add(' TCaption = string;');
- Add(' TChar = char;');
- Add(' TMulti = JSValue;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' i: integer;');
- Add(' s: TCaption;');
- Add(' b: TYesNo;');
- Add(' d: TFloat;');
- Add(' c: char;');
- Add(' m: TMulti;');
- Add('begin');
- Add(' b:=v=v;');
- Add(' b:=v<>v;');
- Add(' b:=v=1;');
- Add(' b:=v<>1;');
- Add(' b:=2=v;');
- Add(' b:=2<>v;');
- Add(' b:=v=i;');
- Add(' b:=i=v;');
- Add(' b:=v=nil;');
- Add(' b:=nil=v;');
- Add(' b:=v=false;');
- Add(' b:=true=v;');
- Add(' b:=v=b;');
- Add(' b:=b=v;');
- Add(' b:=v=s;');
- Add(' b:=s=v;');
- Add(' b:=v=''foo'';');
- Add(' b:=''''=v;');
- Add(' b:=v=d;');
- Add(' b:=d=v;');
- Add(' b:=v=3.4;');
- Add(' b:=5.6=v;');
- Add(' b:=v=c;');
- Add(' b:=c=v;');
- Add(' b:=m=m;');
- Add(' b:=v=m;');
- Add(' b:=m=v;');
- ConvertProgram;
- CheckSource('TestJSValue_Equal',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.i = 0;',
- 'this.s = "";',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.c = "";',
- 'this.m = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.b = $mod.v == $mod.v;',
- '$mod.b = $mod.v != $mod.v;',
- '$mod.b = $mod.v == 1;',
- '$mod.b = $mod.v != 1;',
- '$mod.b = 2 == $mod.v;',
- '$mod.b = 2 != $mod.v;',
- '$mod.b = $mod.v == $mod.i;',
- '$mod.b = $mod.i == $mod.v;',
- '$mod.b = $mod.v == null;',
- '$mod.b = null == $mod.v;',
- '$mod.b = $mod.v == false;',
- '$mod.b = true == $mod.v;',
- '$mod.b = $mod.v == $mod.b;',
- '$mod.b = $mod.b == $mod.v;',
- '$mod.b = $mod.v == $mod.s;',
- '$mod.b = $mod.s == $mod.v;',
- '$mod.b = $mod.v == "foo";',
- '$mod.b = "" == $mod.v;',
- '$mod.b = $mod.v == $mod.d;',
- '$mod.b = $mod.d == $mod.v;',
- '$mod.b = $mod.v == 3.4;',
- '$mod.b = 5.6 == $mod.v;',
- '$mod.b = $mod.v == $mod.c;',
- '$mod.b = $mod.c == $mod.v;',
- '$mod.b = $mod.m == $mod.m;',
- '$mod.b = $mod.v == $mod.m;',
- '$mod.b = $mod.m == $mod.v;',
- '']));
- end;
- procedure TTestModule.TestJSValue_If;
- begin
- StartProgram(false);
- Add([
- 'var',
- ' v: jsvalue;',
- 'begin',
- ' if v then ;',
- ' while v do ;',
- ' repeat until v;',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_If',
- LinesToStr([ // statements
- 'this.v = undefined;',
- '']),
- LinesToStr([ // $mod.$main
- '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');
- Add(' TObject = class');
- Add(' end;');
- Add(' TBirdObject = TObject;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' o: TObject;');
- Add('begin');
- Add(' v:=o;');
- Add(' v:=TObject(o);');
- Add(' v:=TBirdObject(o);');
- Add(' o:=TObject(v);');
- Add(' o:=TBirdObject(v);');
- ConvertProgram;
- CheckSource('TestJSValue_ClassInstance',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "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);',
- '']));
- end;
- procedure TTestModule.TestJSValue_ClassOf;
- begin
- StartProgram(false);
- Add('type');
- Add(' TClass = class of TObject;');
- Add(' TObject = class');
- Add(' end;');
- Add(' TBirds = class of TBird;');
- Add(' TBird = class(TObject) end;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' c: TClass;');
- Add('begin');
- Add(' v:=c;');
- Add(' v:=TObject;');
- Add(' v:=TClass(c);');
- Add(' v:=TBirds(c);');
- Add(' c:=TClass(v);');
- Add(' c:=TBirds(v);');
- ConvertProgram;
- CheckSource('TestJSValue_ClassOf',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'rtl.createClass($mod, "TBird", $mod.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);',
- '']));
- end;
- procedure TTestModule.TestJSValue_ArrayOfJSValue;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TArray = array of JSValue;');
- Add(' TArrgh = tarray;');
- Add(' TArrInt = array of integer;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' TheArray: tarray;');
- Add(' Arr: tarrgh;');
- Add(' i: integer;');
- Add(' ArrInt: tarrint;');
- Add('begin');
- Add(' arr:=thearray;');
- Add(' thearray:=arr;');
- Add(' setlength(arr,2);');
- Add(' setlength(thearray,3);');
- Add(' arr[4]:=v;');
- Add(' arr[5]:=length(thearray);');
- Add(' arr[6]:=nil;');
- Add(' arr[7]:=thearray[8];');
- Add(' arr[low(arr)]:=high(thearray);');
- Add(' arr:=arrint;');
- Add(' arrInt:=tarrint(arr);');
- Add(' if TheArray = nil then ;');
- Add(' if nil = TheArray then ;');
- Add(' if TheArray <> nil then ;');
- Add(' if nil <> TheArray then ;');
- ConvertProgram;
- CheckSource('TestJSValue_ArrayOfJSValue',
- LinesToStr([ // statements
- 'this.v = undefined;',
- 'this.TheArray = [];',
- 'this.Arr = [];',
- 'this.i = 0;',
- 'this.ArrInt = [];',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.Arr = $mod.TheArray;',
- '$mod.TheArray = $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 = $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_Params;
- begin
- StartProgram(false);
- Add('type');
- Add(' integer = longint;');
- Add(' TYesNo = boolean;');
- Add(' TFloat = double;');
- Add(' TCaption = string;');
- Add(' TChar = char;');
- Add('function DoIt(a: jsvalue; const b: jsvalue; var c: jsvalue; out d: jsvalue): jsvalue;');
- Add('var');
- Add(' l: jsvalue;');
- Add('begin');
- Add(' a:=a;');
- Add(' l:=b;');
- Add(' c:=c;');
- Add(' d:=d;');
- Add(' Result:=l;');
- Add('end;');
- Add('function DoSome(a: jsvalue; const b: jsvalue): jsvalue; begin end;');
- Add('var');
- Add(' v: jsvalue;');
- Add(' i: integer;');
- Add(' b: TYesNo;');
- Add(' d: TFloat;');
- Add(' s: TCaption;');
- Add(' c: TChar;');
- Add('begin');
- Add(' v:=doit(v,v,v,v);');
- Add(' i:=integer(dosome(i,i));');
- Add(' b:=TYesNo(dosome(b,b));');
- Add(' d:=TFloat(dosome(d,d));');
- Add(' s:=TCaption(dosome(s,s));');
- Add(' c:=TChar(dosome(c,c));');
- ConvertProgram;
- CheckSource('TestJSValue_Params',
- LinesToStr([ // statements
- 'this.DoIt = function (a, b, c, d) {',
- ' var Result = undefined;',
- ' var l = undefined;',
- ' a = a;',
- ' l = b;',
- ' c.set(c.get());',
- ' d.set(d.get());',
- ' Result = l;',
- ' return Result;',
- '};',
- 'this.DoSome = function (a, b) {',
- ' var Result = undefined;',
- ' return Result;',
- '};',
- 'this.v = undefined;',
- 'this.i = 0;',
- 'this.b = false;',
- 'this.d = 0.0;',
- 'this.s = "";',
- 'this.c = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.v = $mod.DoIt($mod.v, $mod.v, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.v;',
- ' },',
- ' set: function (v) {',
- ' this.p.v = v;',
- ' }',
- '}, {',
- ' p: $mod,',
- ' get: function () {',
- ' return this.p.v;',
- ' },',
- ' set: function (v) {',
- ' this.p.v = v;',
- ' }',
- '});',
- '$mod.i = Math.floor($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($mod, "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($mod, "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_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($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_OverloadNativeInt;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' int53 = nativeint;',
- ' tdatetime = double;',
- 'procedure DoIt(n: nativeint); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' d: double;',
- ' dt: tdatetime;',
- ' i: integer;',
- ' b: byte;',
- ' shi: shortint;',
- ' w: word;',
- ' smi: smallint;',
- ' lw: longword;',
- ' li: longint;',
- ' ni: nativeint;',
- ' nu: nativeuint;',
- 'begin',
- ' DoIt(d);',
- ' DoIt(dt);',
- ' DoIt(i);',
- ' DoIt(b);',
- ' DoIt(shi);',
- ' DoIt(w);',
- ' DoIt(smi);',
- ' DoIt(lw);',
- ' DoIt(li);',
- ' DoIt(ni);',
- ' DoIt(nu);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadNativeInt',
- LinesToStr([ // statements
- 'this.DoIt = function (n) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.d = 0.0;',
- 'this.dt = 0.0;',
- 'this.i = 0;',
- 'this.b = 0;',
- 'this.shi = 0;',
- 'this.w = 0;',
- 'this.smi = 0;',
- 'this.lw = 0;',
- 'this.li = 0;',
- 'this.ni = 0;',
- 'this.nu = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt$1($mod.d);',
- '$mod.DoIt$1($mod.dt);',
- '$mod.DoIt($mod.i);',
- '$mod.DoIt($mod.b);',
- '$mod.DoIt($mod.shi);',
- '$mod.DoIt($mod.w);',
- '$mod.DoIt($mod.smi);',
- '$mod.DoIt($mod.lw);',
- '$mod.DoIt($mod.li);',
- '$mod.DoIt($mod.ni);',
- '$mod.DoIt($mod.nu);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadWord;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' integer = longint;',
- ' int53 = nativeint;',
- ' tdatetime = double;',
- 'procedure DoIt(w: word); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' d: double;',
- ' dt: tdatetime;',
- ' i: integer;',
- ' b: byte;',
- ' shi: shortint;',
- ' w: word;',
- ' smi: smallint;',
- ' lw: longword;',
- ' li: longint;',
- ' ni: nativeint;',
- ' nu: nativeuint;',
- 'begin',
- ' DoIt(d);',
- ' DoIt(dt);',
- ' DoIt(i);',
- ' DoIt(b);',
- ' DoIt(shi);',
- ' DoIt(w);',
- ' DoIt(smi);',
- ' DoIt(lw);',
- ' DoIt(li);',
- ' DoIt(ni);',
- ' DoIt(nu);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadWord',
- LinesToStr([ // statements
- 'this.DoIt = function (w) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.d = 0.0;',
- 'this.dt = 0.0;',
- 'this.i = 0;',
- 'this.b = 0;',
- 'this.shi = 0;',
- 'this.w = 0;',
- 'this.smi = 0;',
- 'this.lw = 0;',
- 'this.li = 0;',
- 'this.ni = 0;',
- 'this.nu = 0;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt$1($mod.d);',
- '$mod.DoIt$1($mod.dt);',
- '$mod.DoIt$1($mod.i);',
- '$mod.DoIt($mod.b);',
- '$mod.DoIt($mod.shi);',
- '$mod.DoIt($mod.w);',
- '$mod.DoIt$1($mod.smi);',
- '$mod.DoIt$1($mod.lw);',
- '$mod.DoIt$1($mod.li);',
- '$mod.DoIt$1($mod.ni);',
- '$mod.DoIt$1($mod.nu);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadString;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' uni = string;',
- ' WChar = char;',
- 'procedure DoIt(s: string); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' s: string;',
- ' c: char;',
- ' u: uni;',
- 'begin',
- ' DoIt(s);',
- ' DoIt(c);',
- ' DoIt(u);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadString',
- LinesToStr([ // statements
- 'this.DoIt = function (s) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.s = "";',
- 'this.c = "";',
- 'this.u = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt($mod.s);',
- '$mod.DoIt($mod.c);',
- '$mod.DoIt($mod.u);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadChar;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' uni = string;',
- ' WChar = char;',
- 'procedure DoIt(c: char); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' s: string;',
- ' c: char;',
- ' u: uni;',
- 'begin',
- ' DoIt(s);',
- ' DoIt(c);',
- ' DoIt(u);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadChar',
- LinesToStr([ // statements
- 'this.DoIt = function (c) {',
- '};',
- 'this.DoIt$1 = function (v) {',
- '};',
- 'this.s = "";',
- 'this.c = "";',
- 'this.u = "";',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.DoIt$1($mod.s);',
- '$mod.DoIt($mod.c);',
- '$mod.DoIt$1($mod.u);',
- '']));
- end;
- procedure TTestModule.TestJSValue_OverloadPointer;
- begin
- StartProgram(false);
- Add([
- 'type',
- ' TObject = class end;',
- 'procedure DoIt(p: pointer); begin end;',
- 'procedure DoIt(v: jsvalue); begin end;',
- 'var',
- ' o: TObject;',
- 'begin',
- ' DoIt(o);',
- '']);
- ConvertProgram;
- CheckSource('TestJSValue_OverloadPointer',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "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.TestRTTI_ProcType;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- '$mod.$rtti.$ProcVar("TProcA", {',
- ' procsig: rtl.newTIProcSig(null)',
- '});',
- '$mod.$rtti.$MethodVar("TMethodB", {',
- ' procsig: rtl.newTIProcSig(null),',
- ' methodkind: 0',
- '});',
- '$mod.$rtti.$ProcVar("TProcC", {',
- ' procsig: rtl.newTIProcSig(null, 2)',
- '});',
- '$mod.$rtti.$ProcVar("TProcD", {',
- ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
- '});',
- '$mod.$rtti.$ProcVar("TProcE", {',
- ' procsig: rtl.newTIProcSig(null, rtl.nativeint)',
- '});',
- '$mod.$rtti.$ProcVar("TProcF", {',
- ' procsig: rtl.newTIProcSig([["p", $mod.$rtti["TProcA"], 2]], rtl.nativeuint)',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TProcA"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_ProcType_ArgFromOtherUnit;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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;',
- '$mod.$rtti.$ProcVar("TProcA", {',
- ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
- '});',
- '']),
- LinesToStr([ // this.$init
- '$impl.p = $mod.$rtti["TProcA"];',
- '$impl.p = $mod.$rtti["TProcB"];',
- '']),
- LinesToStr([ // implementation
- '$mod.$rtti.$ProcVar("TProcB", {',
- ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
- '});',
- '$impl.p = null;',
- '']) );
- end;
- procedure TTestModule.TestRTTI_EnumAndSetType;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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',
- '};',
- '$mod.$rtti.$Enum("TFlag", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TFlag',
- '});',
- '$mod.$rtti.$Set("TFlags", {',
- ' comptype: $mod.$rtti["TFlag"]',
- '});',
- '$mod.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TFlags"]]], $mod.$rtti["TFlag"])',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TFlag"];',
- '$mod.p = $mod.$rtti["TFlags"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_EnumRange;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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',
- '};',
- '$mod.$rtti.$Enum("TFlags$a", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TFlags$a',
- '});',
- '$mod.$rtti.$Set("TFlags", {',
- ' comptype: $mod.$rtti["TFlags$a"]',
- '});',
- 'this.f = {};',
- '']),
- LinesToStr([
- '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
- '']));
- end;
- procedure TTestModule.TestRTTI_StaticArray;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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',
- '};',
- '$mod.$rtti.$Enum("TFlag", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TFlag',
- '});',
- '$mod.$rtti.$StaticArray("TFlagNames", {',
- ' dims: [2],',
- ' eltype: rtl.string',
- '});',
- '$mod.$rtti.$StaticArray("TBoolNames", {',
- ' dims: [2],',
- ' eltype: rtl.string',
- '});',
- '$mod.$rtti.$StaticArray("TByteArray", {',
- ' dims: [32768],',
- ' eltype: rtl.byte',
- '});',
- '$mod.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TBoolNames"]]], $mod.$rtti["TFlagNames"])',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TFlagNames"];',
- '$mod.p = $mod.$rtti["TBoolNames"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_DynArray;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- '$mod.$rtti.$DynArray("TArrStr", {',
- ' eltype: rtl.string',
- '});',
- '$mod.$rtti.$DynArray("TArr2Dim", {',
- ' eltype: $mod.$rtti["TArrStr"]',
- '});',
- '$mod.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TArrStr"]]], $mod.$rtti["TArr2Dim"])',
- '});',
- 'this.p = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TArrStr"];',
- '$mod.p = $mod.$rtti["TArr2Dim"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add('type');
- Add(' TArr = array of array of longint;');
- Add('var a: TArr;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_ArrayNestedAnonymous',
- LinesToStr([ // statements
- '$mod.$rtti.$DynArray("TArr$a", {',
- ' eltype: rtl.longint',
- '});',
- '$mod.$rtti.$DynArray("TArr", {',
- ' eltype: $mod.$rtti["TArr$a"]',
- '});',
- 'this.a = [];',
- '']),
- LinesToStr([ // $mod.$main
- ]));
- end;
- procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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 identifier "Proc" at test1.pp(6,19)',
- nDuplicateIdentifier);
- ConvertProgram;
- end;
- procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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_IndexModifier;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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',
- '};',
- '$mod.$rtti.$Enum("TEnum", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TEnum',
- '});',
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FB = false;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "B1",',
- ' 18,',
- ' rtl.boolean,',
- ' "FB",',
- ' "SetIntBool",',
- ' {',
- ' index: 1',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B2",',
- ' 17,',
- ' rtl.boolean,',
- ' "GetEnumBool",',
- ' "FB",',
- ' {',
- ' index: $mod.TEnum.blue',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I1",',
- ' 19,',
- ' rtl.boolean,',
- ' "GetStrIntBool",',
- ' "SetStrIntBool",',
- ' {',
- ' index: 2',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_StoredModifier;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FB = false;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty("BoolA", 0, rtl.boolean, "FB", "");',
- ' $r.addProperty("BoolB", 4, rtl.boolean, "FB", "");',
- ' $r.addProperty(',
- ' "BoolC",',
- ' 8,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' stored: "FB"',
- ' }',
- ' );',
- ' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
- ' $r.addProperty(',
- ' "BoolE",',
- ' 12,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' stored: "IsBStored"',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_DefaultValue;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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',
- '};',
- '$mod.$rtti.$Enum("TEnum", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TEnum',
- '});',
- 'this.CB = true || false;',
- 'this.CI = 1 + 2;',
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FB = false;',
- ' this.FI = 0;',
- ' this.FE = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "B1",',
- ' 0,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B2",',
- ' 0,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "B3",',
- ' 0,',
- ' rtl.boolean,',
- ' "FB",',
- ' "",',
- ' {',
- ' Default: true',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I1",',
- ' 0,',
- ' rtl.longint,',
- ' "FI",',
- ' "",',
- ' {',
- ' Default: 2',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "I2",',
- ' 0,',
- ' rtl.longint,',
- ' "FI",',
- ' "",',
- ' {',
- ' Default: 3',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "E1",',
- ' 0,',
- ' $mod.$rtti["TEnum"],',
- ' "FE",',
- ' "",',
- ' {',
- ' Default: $mod.TEnum.red',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "E2",',
- ' 0,',
- ' $mod.$rtti["TEnum"],',
- ' "FE",',
- ' "",',
- ' {',
- ' Default: $mod.TEnum.blue',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_DefaultValueSet;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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',
- '};',
- '$mod.$rtti.$Enum("TEnum", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TEnum',
- '});',
- '$mod.$rtti.$Set("TSet", {',
- ' comptype: $mod.$rtti["TEnum"]',
- '});',
- 'this.CSet = rtl.createSet($mod.TEnum.red, $mod.TEnum.blue);',
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FSet = {};',
- ' };',
- ' this.$final = function () {',
- ' this.FSet = undefined;',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "Set1",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' {',
- ' Default: {}',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set2",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' {',
- ' Default: rtl.createSet($mod.TEnum.red)',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set3",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' {',
- ' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "Set4",',
- ' 0,',
- ' $mod.$rtti["TSet"],',
- ' "FSet",',
- ' "",',
- ' {',
- ' Default: $mod.CSet',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_DefaultValueRangeType;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- '$mod.$rtti.$Int("TRg", {',
- ' minvalue: -1,',
- ' maxvalue: 1,',
- ' ordtype: 0',
- '});',
- 'this.l = -1;',
- 'this.h = 1;',
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FV = -1;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty(',
- ' "V1",',
- ' 0,',
- ' $mod.$rtti["TRg"],',
- ' "FV",',
- ' "",',
- ' {',
- ' Default: -1',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_Field;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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(' 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FPropA = "";',
- ' this.VarLI = 0;',
- ' this.VarC = "";',
- ' this.VarS = "";',
- ' this.VarD = 0.0;',
- ' this.VarB = false;',
- ' this.VarLW = 0;',
- ' this.VarSmI = 0;',
- ' this.VarW = 0;',
- ' this.VarShI = 0;',
- ' this.VarBy = 0;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addField("VarLI", rtl.longint);',
- ' $r.addField("VarC", rtl.char);',
- ' $r.addField("VarS", rtl.string);',
- ' $r.addField("VarD", rtl.double);',
- ' $r.addField("VarB", rtl.boolean);',
- ' $r.addField("VarLW", rtl.longword);',
- ' $r.addField("VarSmI", rtl.smallint);',
- ' $r.addField("VarW", rtl.word);',
- ' $r.addField("VarShI", rtl.shortint);',
- ' $r.addField("VarBy", rtl.byte);',
- ' $r.addField("VarExt", rtl.longint);',
- '});',
- 'this.p = null;',
- 'this.Obj = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TObject"];',
- '$mod.p = rtl.pointer;',
- '$mod.p = $mod.Obj.$rtti;',
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_Method;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add('type');
- Add(' TObject = class');
- Add(' private');
- Add(' procedure Internal; external name ''$intern'';');
- Add(' published');
- Add(' procedure Click; virtual; abstract;');
- Add(' procedure Notify(Sender: TObject); virtual; abstract;');
- Add(' function GetNotify: boolean; external name ''GetNotify'';');
- Add(' procedure Println(a,b: longint); varargs; virtual; abstract;');
- Add(' end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_Class_Method',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("Click", 0, null);',
- ' $r.addMethod("Notify", 0, [["Sender", $r]]);',
- ' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});',
- ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {',
- ' flags: 2',
- ' });',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_MethodArgFlags;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- '$r.addMethod("OpenArray", 0, [["Args", rtl.string, 10]]);',
- '$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]]);',
- '$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]]);',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_Property;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FColor = 0;',
- ' this.FColorStored = false;',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addProperty("ColorA", 0, rtl.longint, "FColor", "");',
- ' $r.addProperty("ColorB", 0, rtl.longint, "", "FColor");',
- ' $r.addProperty("ColorC", 3, rtl.longint, "GetColor", "SetColor");',
- ' $r.addProperty(',
- ' "ColorD",',
- ' 8,',
- ' rtl.longint,',
- ' "FColor",',
- ' "FColor",',
- ' {',
- ' stored: "FColorStored"',
- ' }',
- ' );',
- ' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
- ' $r.addProperty(',
- ' "ExtSizeB",',
- ' 11,',
- ' rtl.longint,',
- ' "$getSize",',
- ' "$setSize",',
- ' {',
- ' stored: "$extSizeStored"',
- ' }',
- ' );',
- ' $r.addProperty(',
- ' "ExtSizeC",',
- ' 12,',
- ' rtl.longint,',
- ' "$extSize",',
- ' "$extSize",',
- ' {',
- ' stored: "$getExtSizeStored"',
- ' }',
- ' );',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Class_PropertyParams;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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($mod, "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_OverrideMethod;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addMethod("DoIt", 0, null);',
- '});',
- 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
- ' this.DoIt = function () {',
- ' };',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_OverloadProperty;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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($mod, "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($mod, "TSky", $mod.TObject, function () {',
- ' var $r = this.$rtti;',
- ' $r.addProperty("Flag", 0, rtl.longint, "", "FFlag");',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_ClassForward;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- '$mod.$rtti.$Class("TBridge");',
- '$mod.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TBridge"])',
- '});',
- 'rtl.createClass($mod, "TOger", $mod.TObject, function () {',
- ' this.$init = function () {',
- ' $mod.TObject.$init.call(this);',
- ' this.FBridge = null;',
- ' };',
- ' this.$final = function () {',
- ' this.FBridge = undefined;',
- ' $mod.TObject.$final.call(this);',
- ' };',
- ' var $r = this.$rtti;',
- ' $r.addField("FBridge", $mod.$rtti["TBridge"]);',
- ' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]]);',
- ' $r.addProperty("Bridge", 2, $mod.$rtti["TBridge"], "FBridge", "SetBridge");',
- '});',
- 'rtl.createClass($mod, "TBridge", $mod.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
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- '$mod.$rtti.$Class("TObject");',
- '$mod.$rtti.$ClassRef("TClass", {',
- ' instancetype: $mod.$rtti["TObject"]',
- '});',
- '$mod.$rtti.$ProcVar("TProcA", {',
- ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TClass"])',
- '});',
- 'rtl.createClass($mod, "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"]);',
- '});',
- '$mod.$rtti.$Class("TFox");',
- 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
- '});',
- '$mod.$rtti.$ClassRef("TBirds", {',
- ' instancetype: $mod.$rtti["TBird"]',
- '});',
- 'rtl.createClass($mod, "TFox", $mod.TObject, function () {',
- '});',
- '$mod.$rtti.$ClassRef("TFoxes", {',
- ' instancetype: $mod.$rtti["TFox"]',
- '});',
- '$mod.$rtti.$Class("TCow");',
- '$mod.$rtti.$ClassRef("TCows", {',
- ' instancetype: $mod.$rtti["TCow"]',
- '});',
- 'rtl.createClass($mod, "TCow", $mod.TObject, function () {',
- '});',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_Record;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- 'this.TPoint = function (s) {',
- ' if (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' } else {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- '};',
- '$mod.$rtti.$Record("TPoint", {}).addFields("x", rtl.longint, "y", rtl.longint);',
- 'this.p = null;',
- 'this.r = new $mod.TPoint();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TPoint"];',
- '$mod.p = $mod.$rtti["TPoint"];',
- '$mod.p = rtl.longint;',
- '']));
- end;
- procedure TTestModule.TestRTTI_RecordAnonymousArray;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add('type');
- Add(' TFloatRec = record');
- Add(' 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
- 'this.TFloatRec = function (s) {',
- ' if (s) {',
- ' this.d = s.d;',
- ' } else {',
- ' this.d = [];',
- ' };',
- ' this.$equal = function (b) {',
- ' return this.d === b.d;',
- ' };',
- '};',
- '$mod.$rtti.$DynArray("TFloatRec.d$a", {',
- ' eltype: rtl.char',
- '});',
- '$mod.$rtti.$Record("TFloatRec", {}).addFields("d", $mod.$rtti["TFloatRec.d$a"]);',
- 'this.p = null;',
- 'this.r = new $mod.TFloatRec();',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.p = $mod.$rtti["TFloatRec"];',
- '$mod.p = $mod.$rtti["TFloatRec"];',
- '$mod.p = $mod.$rtti["TFloatRec.d$a"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_LocalTypes;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add('procedure DoIt;');
- Add('type');
- Add(' integer = longint;');
- Add(' TPoint = record');
- Add(' x,y: integer;');
- Add(' end;');
- Add('begin');
- Add('end;');
- Add('begin');
- ConvertProgram;
- CheckSource('TestRTTI_LocalTypes',
- LinesToStr([ // statements
- 'this.DoIt = function () {',
- ' this.TPoint = function (s) {',
- ' if (s) {',
- ' this.x = s.x;',
- ' this.y = s.y;',
- ' } else {',
- ' this.x = 0;',
- ' this.y = 0;',
- ' };',
- ' this.$equal = function (b) {',
- ' return (this.x === b.x) && (this.y === b.y);',
- ' };',
- ' };',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_BaseTypes;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add('type');
- Add(' TCaption = string;');
- Add(' TYesNo = boolean;');
- Add(' TLetter = char;');
- Add(' TFloat = double;');
- Add(' TPtr = pointer;');
- Add(' TShortInt = shortint;');
- Add(' TByte = byte;');
- Add(' TSmallInt = smallint;');
- Add(' TWord = word;');
- Add(' TInt32 = longint;');
- Add(' TDWord = longword;');
- Add(' TValue = jsvalue;');
- Add('var p: TPtr;');
- Add('begin');
- Add(' p:=typeinfo(string);');
- Add(' p:=typeinfo(tcaption);');
- Add(' p:=typeinfo(boolean);');
- Add(' p:=typeinfo(tyesno);');
- Add(' p:=typeinfo(char);');
- Add(' p:=typeinfo(tletter);');
- Add(' p:=typeinfo(double);');
- Add(' p:=typeinfo(tfloat);');
- Add(' p:=typeinfo(pointer);');
- Add(' p:=typeinfo(tptr);');
- Add(' p:=typeinfo(shortint);');
- Add(' p:=typeinfo(tshortint);');
- Add(' p:=typeinfo(byte);');
- Add(' p:=typeinfo(tbyte);');
- Add(' p:=typeinfo(smallint);');
- Add(' p:=typeinfo(tsmallint);');
- Add(' p:=typeinfo(word);');
- Add(' p:=typeinfo(tword);');
- Add(' p:=typeinfo(longword);');
- Add(' p:=typeinfo(tdword);');
- Add(' p:=typeinfo(jsvalue);');
- Add(' 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_LocalFail;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- 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
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
- Add(' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;');
- Add(' TFlag = (up,down);');
- Add(' TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;');
- Add(' TFlags = set of TFlag;');
- Add(' TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;');
- Add('var');
- Add(' ti: TTypeInfo;');
- Add(' tiInt: TTypeInfoInteger;');
- Add(' tiEnum: TTypeInfoEnum;');
- Add(' tiSet: TTypeInfoSet;');
- Add('begin');
- Add(' ti:=typeinfo(string);');
- Add(' ti:=typeinfo(boolean);');
- Add(' ti:=typeinfo(char);');
- Add(' ti:=typeinfo(double);');
- Add(' tiInt:=typeinfo(shortint);');
- Add(' tiInt:=typeinfo(byte);');
- Add(' tiInt:=typeinfo(smallint);');
- Add(' tiInt:=typeinfo(word);');
- Add(' tiInt:=typeinfo(longint);');
- Add(' tiInt:=typeinfo(longword);');
- Add(' ti:=typeinfo(jsvalue);');
- Add(' tiEnum:=typeinfo(tflag);');
- Add(' tiSet:=typeinfo(tflags);');
- ConvertProgram;
- CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
- LinesToStr([ // statements
- 'this.TFlag = {',
- ' "0": "up",',
- ' up: 0,',
- ' "1": "down",',
- ' down: 1',
- '};',
- '$mod.$rtti.$Enum("TFlag", {',
- ' minvalue: 0,',
- ' maxvalue: 1,',
- ' ordtype: 1,',
- ' enumtype: this.TFlag',
- '});',
- '$mod.$rtti.$Set("TFlags", {',
- ' comptype: $mod.$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
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
- Add(' TStaticArr = array[boolean] of string;');
- Add(' TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;');
- Add(' TDynArr = array of string;');
- Add(' TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;');
- Add(' TProc = procedure;');
- Add(' TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
- Add(' TMethod = procedure of object;');
- Add(' TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
- 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
- ' $mod.$rtti.$StaticArray("TStaticArr", {',
- ' dims: [2],',
- ' eltype: rtl.string',
- '});',
- '$mod.$rtti.$DynArray("TDynArr", {',
- ' eltype: rtl.string',
- '});',
- '$mod.$rtti.$ProcVar("TProc", {',
- ' procsig: rtl.newTIProcSig(null)',
- '});',
- '$mod.$rtti.$MethodVar("TMethod", {',
- ' procsig: rtl.newTIProcSig(null),',
- ' methodkind: 0',
- '});',
- 'this.StaticArray = rtl.arraySetLength(null,"",2);',
- 'this.tiStaticArray = null;',
- 'this.DynArray = [];',
- 'this.tiDynArray = null;',
- 'this.ProcVar = null;',
- 'this.tiProcVar = null;',
- 'this.MethodVar = null;',
- 'this.tiMethodVar = null;',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
- '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
- '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
- '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
- '$mod.tiProcVar = $mod.$rtti["TProc"];',
- '$mod.tiProcVar = $mod.$rtti["TProc"];',
- '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
- '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
- '']));
- end;
- procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
- begin
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add('{$modeswitch externalclass}');
- Add('type');
- Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
- Add(' TRec = record end;');
- Add(' TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
- // ToDo: ^PRec
- Add(' TObject = class end;');
- Add(' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
- Add(' TClass = class of tobject;');
- Add(' TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
- Add(' TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
- Add('var');
- Add(' Rec: trec;');
- Add(' tiRecord: ttypeinforecord;');
- Add(' Obj: tobject;');
- Add(' tiClass: ttypeinfoclass;');
- Add(' aClass: tclass;');
- Add(' tiClassRef: ttypeinfoclassref;');
- // ToDo: ^PRec
- 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
- 'this.TRec = function (s) {',
- '};',
- '$mod.$rtti.$Record("TRec", {});',
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- '$mod.$rtti.$ClassRef("TClass", {',
- ' instancetype: $mod.$rtti["TObject"]',
- '});',
- 'this.Rec = new $mod.TRec();',
- '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
- Converter.Options:=Converter.Options-[coNoTypeInfo];
- StartProgram(false);
- Add([
- '{$modeswitch externalclass}',
- 'type',
- ' TClass = class of tobject;',
- ' TObject = class',
- ' function MyClass: TClass;',
- ' class function ClassType: TClass;',
- ' end;',
- ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
- ' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
- 'function TObject.MyClass: TClass;',
- 'var t: TTypeInfoClass;',
- 'begin',
- ' t:=TypeInfo(Self);',
- ' t:=TypeInfo(Result);',
- '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
- '$mod.$rtti.$Class("TObject");',
- '$mod.$rtti.$ClassRef("TClass", {',
- ' instancetype: $mod.$rtti["TObject"]',
- '});',
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' };',
- ' this.$final = function () {',
- ' };',
- ' this.MyClass = function () {',
- ' var Result = null;',
- ' var t = null;',
- ' t = this.$rtti;',
- ' t = Result.$rtti;',
- ' 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.TestResourcestringProgram;
- begin
- StartProgram(false);
- Add([
- 'const Bar = ''bar'';',
- 'resourcestring',
- ' Red = ''red'';',
- ' Foobar = ''fOo''+bar;',
- 'var s: string;',
- ' c: char;',
- 'begin',
- ' s:=red;',
- ' s:=test1.red;',
- ' c:=red[1];',
- ' c:=test1.red[2];',
- ' if red=foobar then ;',
- ' if red[3]=red[4] then ;']);
- ConvertProgram;
- CheckSource('TestResourcestringProgram',
- LinesToStr([ // statements
- 'this.Bar = "bar";',
- 'this.s = "";',
- 'this.c = "";',
- '$mod.$resourcestrings = {',
- ' Red: {',
- ' org: "red"',
- ' },',
- ' Foobar: {',
- ' org: "fOobar"',
- ' }',
- '};',
- '']),
- LinesToStr([ // $mod.$main
- '$mod.s = rtl.getResStr(pas.program, "Red");',
- '$mod.s = rtl.getResStr(pas.program, "Red");',
- '$mod.c = rtl.getResStr(pas.program, "Red").charAt(0);',
- '$mod.c = rtl.getResStr(pas.program, "Red").charAt(1);',
- 'if (rtl.getResStr(pas.program, "Red") === rtl.getResStr(pas.program, "Foobar")) ;',
- 'if (rtl.getResStr(pas.program, "Red").charAt(2) === rtl.getResStr(pas.program, "Red").charAt(3)) ;',
- '']));
- end;
- procedure TTestModule.TestResourcestringUnit;
- begin
- StartUnit(false);
- Add([
- 'interface',
- '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];']);
- 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(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
- '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
- '$mod.s = rtl.getResStr(pas.Test1, "Blue").charAt(0) + rtl.getResStr(pas.Test1, "ImplGreen").charAt(1);',
- '']));
- 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.TestAtributes_Ignore;
- begin
- StartProgram(false);
- Add([
- '{$modeswitch ignoreattributes}',
- 'type',
- ' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
- ' TObject = class',
- ' [custom5()] FS: string;',
- ' [customProp] property S: string read FS;',
- ' end;',
- 'var',
- ' [custom6]',
- ' o: TObject;',
- 'begin',
- '']);
- ConvertProgram;
- CheckSource('TestAtributes_Ignore',
- LinesToStr([ // statements
- 'rtl.createClass($mod, "TObject", null, function () {',
- ' this.$init = function () {',
- ' this.FS = "";',
- ' };',
- ' this.$final = function () {',
- ' };',
- '});',
- 'this.o = null;',
- '']),
- LinesToStr([ // $mod.$main
- '']));
- end;
- Initialization
- RegisterTests([TTestModule]);
- end.
|