tcfiler.pas 123 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658
  1. {
  2. This file is part of the Free Component Library (FCL)
  3. Copyright (c) 2018 by Michael Van Canneyt
  4. Unit tests for Pascal-to-Javascript precompile class.
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************
  11. Examples:
  12. ./testpas2js --suite=TTestPrecompile.TestPC_EmptyUnit
  13. }
  14. unit TCFiler;
  15. {$i ../src/pastojs.inc}
  16. interface
  17. uses
  18. Classes, SysUtils, fpcunit, testregistry,
  19. jstree,
  20. PasTree, PScanner, PParser, PasResolveEval, PasResolver, PasUseAnalyzer,
  21. Pas2jsUseAnalyzer, FPPas2Js, Pas2JsFiler,
  22. tcmodules;
  23. type
  24. TPCCheckFlag = (
  25. PCCGeneric // inside generic proc body
  26. );
  27. TPCCheckFlags = set of TPCCheckFlag;
  28. TPCCheckedElementPair = class
  29. public
  30. Orig, Rest: TPasElement;
  31. end;
  32. { TCustomTestPrecompile }
  33. TCustomTestPrecompile = Class(TCustomTestModule)
  34. private
  35. FAnalyzer: TPas2JSAnalyzer;
  36. FInitialFlags: TPCUInitialFlags;
  37. FPCUReader: TPCUReader;
  38. FPCUWriter: TPCUWriter;
  39. FRestAnalyzer: TPas2JSAnalyzer;
  40. FCheckedElements: TPasAnalyzerKeySet; // keyset of TPCCheckedElementPair, key is Orig
  41. procedure OnFilerGetSrc(Sender: TObject; aFilename: string; out p: PChar;
  42. out Count: integer);
  43. function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
  44. function OnConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean;
  45. function OnRestConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
  46. function OnRestConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean;
  47. function OnRestResolverFindUnit(const aUnitName: String): TPasModule;
  48. protected
  49. procedure SetUp; override;
  50. procedure TearDown; override;
  51. function CreateConverter: TPasToJSConverter; override;
  52. procedure ParseUnit; override;
  53. procedure WriteReadUnit; virtual;
  54. procedure StartParsing; override;
  55. function CheckRestoredObject(const Path: string; Orig, Rest: TObject): boolean; virtual;
  56. procedure CheckRestoredJS(const Path, Orig, Rest: string); virtual;
  57. procedure CheckRestoredStringList(const Path: string; Orig, Rest: TStrings); virtual;
  58. // check restored parser+resolver
  59. procedure CheckRestoredResolver(Original, Restored: TPas2JSResolver; Flags: TPCCheckFlags); virtual;
  60. procedure CheckRestoredDeclarations(const Path: string; Orig, Rest: TPasDeclarations; Flags: TPCCheckFlags); virtual;
  61. procedure CheckRestoredSection(const Path: string; Orig, Rest: TPasSection; Flags: TPCCheckFlags); virtual;
  62. procedure CheckRestoredModule(const Path: string; Orig, Rest: TPasModule; Flags: TPCCheckFlags); virtual;
  63. procedure CheckRestoredScopeReference(const Path: string; Orig, Rest: TPasScope; Flags: TPCCheckFlags); virtual;
  64. procedure CheckRestoredElementBase(const Path: string; Orig, Rest: TPasElementBase; Flags: TPCCheckFlags); virtual;
  65. procedure CheckRestoredResolveData(const Path: string; Orig, Rest: TResolveData; Flags: TPCCheckFlags); virtual;
  66. procedure CheckRestoredPasScope(const Path: string; Orig, Rest: TPasScope; Flags: TPCCheckFlags); virtual;
  67. procedure CheckRestoredLocalVar(const Path: string; Orig, Rest: TPas2JSStoredLocalVar); virtual;
  68. procedure CheckRestoredModuleScope(const Path: string; Orig, Rest: TPas2JSModuleScope; Flags: TPCCheckFlags); virtual;
  69. procedure CheckRestoredIdentifierScope(const Path: string; Orig, Rest: TPasIdentifierScope; Flags: TPCCheckFlags); virtual;
  70. procedure CheckRestoredSectionScope(const Path: string; Orig, Rest: TPas2JSSectionScope; Flags: TPCCheckFlags); virtual;
  71. procedure CheckRestoredInitialFinalizationScope(const Path: string; Orig, Rest: TPas2JSInitialFinalizationScope; Flags: TPCCheckFlags); virtual;
  72. procedure CheckRestoredEnumTypeScope(const Path: string; Orig, Rest: TPasEnumTypeScope; Flags: TPCCheckFlags); virtual;
  73. procedure CheckRestoredRecordScope(const Path: string; Orig, Rest: TPas2jsRecordScope; Flags: TPCCheckFlags); virtual;
  74. procedure CheckRestoredClassScope(const Path: string; Orig, Rest: TPas2JSClassScope; Flags: TPCCheckFlags); virtual;
  75. procedure CheckRestoredProcScope(const Path: string; Orig, Rest: TPas2JSProcedureScope; Flags: TPCCheckFlags); virtual;
  76. procedure CheckRestoredProcTypeScope(const Path: string; Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags); virtual;
  77. procedure CheckRestoredArrayScope(const Path: string; Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags); virtual;
  78. procedure CheckRestoredPrecompiledJS(const Path: string; OrigEl: TPasElement; Orig: TPas2JSPrecompiledJS; RestEl: TPasElement; Rest: TPas2JSPrecompiledJS; Flags: TPCCheckFlags); virtual;
  79. procedure CheckRestoredScopeRefs(const Path: string; Orig, Rest: TPasScopeReferences; Flags: TPCCheckFlags); virtual;
  80. procedure CheckRestoredPropertyScope(const Path: string; Orig, Rest: TPasPropertyScope; Flags: TPCCheckFlags); virtual;
  81. procedure CheckRestoredGenericParamScope(const Path: string; Orig, Rest: TPasGenericParamsScope; Flags: TPCCheckFlags); virtual;
  82. procedure CheckRestoredSpecializeTypeData(const Path: string; Orig, Rest: TPasSpecializeTypeData; Flags: TPCCheckFlags); virtual;
  83. procedure CheckRestoredResolvedReference(const Path: string; Orig, Rest: TResolvedReference; Flags: TPCCheckFlags); virtual;
  84. procedure CheckRestoredEvalValue(const Path: string; Orig, Rest: TResEvalValue); virtual;
  85. procedure CheckRestoredCustomData(const Path: string; RestoredEl: TPasElement; Orig, Rest: TObject; Flags: TPCCheckFlags); virtual;
  86. procedure CheckRestoredReference(const Path: string; Orig, Rest: TPasElement); virtual;
  87. procedure CheckRestoredElOrRef(const Path: string; Orig, OrigProp, Rest, RestProp: TPasElement; Flags: TPCCheckFlags); virtual;
  88. procedure CheckRestoredAnalyzerElement(const Path: string; Orig, Rest: TPasElement); virtual;
  89. procedure CheckRestoredElement(const Path: string; Orig, Rest: TPasElement; Flags: TPCCheckFlags); virtual;
  90. procedure CheckRestoredElementList(const Path: string; Orig, Rest: TFPList; Flags: TPCCheckFlags); virtual;
  91. procedure CheckRestoredElementArray(const Path: string; Orig, Rest: TPasElementArray; Flags: TPCCheckFlags); virtual;
  92. procedure CheckRestoredElRefList(const Path: string; OrigParent: TPasElement;
  93. Orig: TFPList; RestParent: TPasElement; Rest: TFPList; AllowInSitu: boolean; Flags: TPCCheckFlags); virtual;
  94. procedure CheckRestoredPasExpr(const Path: string; Orig, Rest: TPasExpr; Flags: TPCCheckFlags); virtual;
  95. procedure CheckRestoredUnaryExpr(const Path: string; Orig, Rest: TUnaryExpr; Flags: TPCCheckFlags); virtual;
  96. procedure CheckRestoredBinaryExpr(const Path: string; Orig, Rest: TBinaryExpr; Flags: TPCCheckFlags); virtual;
  97. procedure CheckRestoredPrimitiveExpr(const Path: string; Orig, Rest: TPrimitiveExpr; Flags: TPCCheckFlags); virtual;
  98. procedure CheckRestoredBoolConstExpr(const Path: string; Orig, Rest: TBoolConstExpr; Flags: TPCCheckFlags); virtual;
  99. procedure CheckRestoredParamsExpr(const Path: string; Orig, Rest: TParamsExpr; Flags: TPCCheckFlags); virtual;
  100. procedure CheckRestoredProcedureExpr(const Path: string; Orig, Rest: TProcedureExpr; Flags: TPCCheckFlags); virtual;
  101. procedure CheckRestoredRecordValues(const Path: string; Orig, Rest: TRecordValues; Flags: TPCCheckFlags); virtual;
  102. procedure CheckRestoredPasExprArray(const Path: string; Orig, Rest: TPasExprArray; Flags: TPCCheckFlags); virtual;
  103. procedure CheckRestoredArrayValues(const Path: string; Orig, Rest: TArrayValues; Flags: TPCCheckFlags); virtual;
  104. procedure CheckRestoredResString(const Path: string; Orig, Rest: TPasResString; Flags: TPCCheckFlags); virtual;
  105. procedure CheckRestoredAliasType(const Path: string; Orig, Rest: TPasAliasType; Flags: TPCCheckFlags); virtual;
  106. procedure CheckRestoredPointerType(const Path: string; Orig, Rest: TPasPointerType; Flags: TPCCheckFlags); virtual;
  107. procedure CheckRestoredSpecializedType(const Path: string; Orig, Rest: TPasSpecializeType; Flags: TPCCheckFlags); virtual;
  108. procedure CheckRestoredInlineSpecializedExpr(const Path: string; Orig, Rest: TInlineSpecializeExpr; Flags: TPCCheckFlags); virtual;
  109. procedure CheckRestoredGenericTemplateType(const Path: string; Orig, Rest: TPasGenericTemplateType; Flags: TPCCheckFlags); virtual;
  110. procedure CheckRestoredRangeType(const Path: string; Orig, Rest: TPasRangeType; Flags: TPCCheckFlags); virtual;
  111. procedure CheckRestoredArrayType(const Path: string; Orig, Rest: TPasArrayType; Flags: TPCCheckFlags); virtual;
  112. procedure CheckRestoredFileType(const Path: string; Orig, Rest: TPasFileType; Flags: TPCCheckFlags); virtual;
  113. procedure CheckRestoredEnumValue(const Path: string; Orig, Rest: TPasEnumValue; Flags: TPCCheckFlags); virtual;
  114. procedure CheckRestoredEnumType(const Path: string; Orig, Rest: TPasEnumType; Flags: TPCCheckFlags); virtual;
  115. procedure CheckRestoredSetType(const Path: string; Orig, Rest: TPasSetType; Flags: TPCCheckFlags); virtual;
  116. procedure CheckRestoredVariant(const Path: string; Orig, Rest: TPasVariant; Flags: TPCCheckFlags); virtual;
  117. procedure CheckRestoredRecordType(const Path: string; Orig, Rest: TPasRecordType; Flags: TPCCheckFlags); virtual;
  118. procedure CheckRestoredClassType(const Path: string; Orig, Rest: TPasClassType; Flags: TPCCheckFlags); virtual;
  119. procedure CheckRestoredArgument(const Path: string; Orig, Rest: TPasArgument; Flags: TPCCheckFlags); virtual;
  120. procedure CheckRestoredProcedureType(const Path: string; Orig, Rest: TPasProcedureType; Flags: TPCCheckFlags); virtual;
  121. procedure CheckRestoredResultElement(const Path: string; Orig, Rest: TPasResultElement; Flags: TPCCheckFlags); virtual;
  122. procedure CheckRestoredFunctionType(const Path: string; Orig, Rest: TPasFunctionType; Flags: TPCCheckFlags); virtual;
  123. procedure CheckRestoredStringType(const Path: string; Orig, Rest: TPasStringType; Flags: TPCCheckFlags); virtual;
  124. procedure CheckRestoredVariable(const Path: string; Orig, Rest: TPasVariable; Flags: TPCCheckFlags); virtual;
  125. procedure CheckRestoredExportSymbol(const Path: string; Orig, Rest: TPasExportSymbol; Flags: TPCCheckFlags); virtual;
  126. procedure CheckRestoredConst(const Path: string; Orig, Rest: TPasConst; Flags: TPCCheckFlags); virtual;
  127. procedure CheckRestoredProperty(const Path: string; Orig, Rest: TPasProperty; Flags: TPCCheckFlags); virtual;
  128. procedure CheckRestoredMethodResolution(const Path: string; Orig, Rest: TPasMethodResolution; Flags: TPCCheckFlags); virtual;
  129. procedure CheckRestoredProcNameParts(const Path: string; Orig, Rest: TPasProcedure; Flags: TPCCheckFlags); virtual;
  130. procedure CheckRestoredProcedure(const Path: string; Orig, Rest: TPasProcedure; Flags: TPCCheckFlags); virtual;
  131. procedure CheckRestoredOperator(const Path: string; Orig, Rest: TPasOperator; Flags: TPCCheckFlags); virtual;
  132. procedure CheckRestoredProcedureBody(const Path: string; Orig, Rest: TProcedureBody; Flags: TPCCheckFlags); virtual;
  133. procedure CheckRestoredAttributes(const Path: string; Orig, Rest: TPasAttributes; Flags: TPCCheckFlags); virtual;
  134. procedure CheckRestoredImplCommand(const Path: string; Orig, Rest: TPasImplCommand; Flags: TPCCheckFlags); virtual;
  135. procedure CheckRestoredImplBeginBlock(const Path: string; Orig, Rest: TPasImplBeginBlock; Flags: TPCCheckFlags); virtual;
  136. procedure CheckRestoredImplAsmStatement(const Path: string; Orig, Rest: TPasImplAsmStatement; Flags: TPCCheckFlags); virtual;
  137. procedure CheckRestoredImplRepeatUntil(const Path: string; Orig, Rest: TPasImplRepeatUntil; Flags: TPCCheckFlags); virtual;
  138. procedure CheckRestoredImplIfElse(const Path: string; Orig, Rest: TPasImplIfElse; Flags: TPCCheckFlags); virtual;
  139. procedure CheckRestoredImplWhileDo(const Path: string; Orig, Rest: TPasImplWhileDo; Flags: TPCCheckFlags); virtual;
  140. procedure CheckRestoredImplWithDo(const Path: string; Orig, Rest: TPasImplWithDo; Flags: TPCCheckFlags); virtual;
  141. procedure CheckRestoredImplCaseOf(const Path: string; Orig, Rest: TPasImplCaseOf; Flags: TPCCheckFlags); virtual;
  142. procedure CheckRestoredImplCaseStatement(const Path: string; Orig, Rest: TPasImplCaseStatement; Flags: TPCCheckFlags); virtual;
  143. procedure CheckRestoredImplCaseElse(const Path: string; Orig, Rest: TPasImplCaseElse; Flags: TPCCheckFlags); virtual;
  144. procedure CheckRestoredImplForLoop(const Path: string; Orig, Rest: TPasImplForLoop; Flags: TPCCheckFlags); virtual;
  145. procedure CheckRestoredImplAssign(const Path: string; Orig, Rest: TPasImplAssign; Flags: TPCCheckFlags); virtual;
  146. procedure CheckRestoredImplSimple(const Path: string; Orig, Rest: TPasImplSimple; Flags: TPCCheckFlags); virtual;
  147. procedure CheckRestoredImplTry(const Path: string; Orig, Rest: TPasImplTry; Flags: TPCCheckFlags); virtual;
  148. procedure CheckRestoredImplTryHandler(const Path: string; Orig, Rest: TPasImplTryHandler; Flags: TPCCheckFlags); virtual;
  149. procedure CheckRestoredImplExceptOn(const Path: string; Orig, Rest: TPasImplExceptOn; Flags: TPCCheckFlags); virtual;
  150. procedure CheckRestoredImplRaise(const Path: string; Orig, Rest: TPasImplRaise; Flags: TPCCheckFlags); virtual;
  151. public
  152. property Analyzer: TPas2JSAnalyzer read FAnalyzer;
  153. property RestAnalyzer: TPas2JSAnalyzer read FRestAnalyzer;
  154. property PCUWriter: TPCUWriter read FPCUWriter write FPCUWriter;
  155. property PCUReader: TPCUReader read FPCUReader write FPCUReader;
  156. property InitialFlags: TPCUInitialFlags read FInitialFlags;
  157. end;
  158. { TTestPrecompile }
  159. TTestPrecompile = class(TCustomTestPrecompile)
  160. published
  161. procedure Test_Base256VLQ;
  162. procedure TestPC_EmptyUnit;
  163. procedure TestPC_Const;
  164. procedure TestPC_Var;
  165. procedure TestPC_Enum;
  166. procedure TestPC_Set;
  167. procedure TestPC_Set_InFunction;
  168. procedure TestPC_SetOfAnonymousEnumType;
  169. procedure TestPC_Record;
  170. procedure TestPC_Record_InFunction;
  171. procedure TestPC_RecordAdv;
  172. procedure TestPC_JSValue;
  173. procedure TestPC_Array;
  174. procedure TestPC_ArrayOfAnonymous;
  175. procedure TestPC_Array_InFunction;
  176. procedure TestPC_Proc;
  177. procedure TestPC_Proc_Nested;
  178. procedure TestPC_Proc_LocalConst;
  179. procedure TestPC_Proc_UTF8;
  180. procedure TestPC_Proc_Arg;
  181. procedure TestPC_ProcType;
  182. procedure TestPC_Proc_Anonymous;
  183. procedure TestPC_Proc_ArrayOfConst;
  184. procedure TestPC_Class;
  185. procedure TestPC_ClassForward;
  186. procedure TestPC_ClassConstructor;
  187. procedure TestPC_ClassDestructor;
  188. procedure TestPC_ClassDispatchMessage;
  189. procedure TestPC_Initialization;
  190. procedure TestPC_BoolSwitches;
  191. procedure TestPC_ClassInterface;
  192. procedure TestPC_Attributes;
  193. procedure TestPC_GenericFunction_Assign;
  194. procedure TestPC_GenericFunction_Asm;
  195. procedure TestPC_GenericFunction_RepeatUntil;
  196. procedure TestPC_GenericFunction_IfElse;
  197. procedure TestPC_GenericFunction_WhileDo;
  198. procedure TestPC_GenericFunction_WithDo;
  199. procedure TestPC_GenericFunction_CaseOf;
  200. procedure TestPC_GenericFunction_ForLoop;
  201. procedure TestPC_GenericFunction_Simple;
  202. procedure TestPC_GenericFunction_TryFinally;
  203. procedure TestPC_GenericFunction_TryExcept;
  204. procedure TestPC_GenericFunction_LocalProc;
  205. procedure TestPC_GenericFunction_AnonymousProc;
  206. procedure TestPC_GenericClass;
  207. procedure TestPC_GenericMethod;
  208. // ToDo: GenericMethod Calls, ProcTypes
  209. procedure TestPC_SpecializeClassSameUnit;
  210. procedure TestPC_Specialize_LocalTypeInUnit;
  211. procedure TestPC_Specialize_ClassForward;
  212. procedure TestPC_InlineSpecialize_LocalTypeInUnit;
  213. procedure TestPC_Specialize_Array;
  214. procedure TestPC_Specialize_ProcType;
  215. // ToDo: half specialize TBird<T> = class a: TAnt<word,T>; end;
  216. // ToDo: no specialize: TBird<T> = class a: TBird<T>; end;
  217. procedure TestPC_Constraints;
  218. // ToDo: constraints
  219. // ToDo: unit impl declarations used by generics
  220. procedure TestPC_GenericClass_InlineSpecialize;
  221. procedure TestPC_UseUnit;
  222. procedure TestPC_UseUnit_Class;
  223. procedure TestPC_UseIndirectUnit;
  224. end;
  225. function CompareListOfProcScopeRef(Item1, Item2: Pointer): integer;
  226. function CompareCheckedElementPairs(Item1, Item2: Pointer): integer;
  227. function CompareElWithCheckedElementPair(Key, Item: Pointer): integer;
  228. implementation
  229. function CompareListOfProcScopeRef(Item1, Item2: Pointer): integer;
  230. var
  231. Ref1: TPasScopeReference absolute Item1;
  232. Ref2: TPasScopeReference absolute Item2;
  233. begin
  234. Result:=CompareText(GetObjPath(Ref1.Element),GetObjPath(Ref2.Element));
  235. if Result<>0 then exit;
  236. Result:=ComparePointer(Ref1.Element,Ref2.Element);
  237. end;
  238. function CompareCheckedElementPairs(Item1, Item2: Pointer): integer;
  239. var
  240. Pair1: TPCCheckedElementPair absolute Item1;
  241. Pair2: TPCCheckedElementPair absolute Item2;
  242. begin
  243. Result:=ComparePointer(Pair1.Orig,Pair2.Orig);
  244. end;
  245. function CompareElWithCheckedElementPair(Key, Item: Pointer): integer;
  246. var
  247. El: TPasElement absolute Key;
  248. Pair: TPCCheckedElementPair absolute Item;
  249. begin
  250. Result:=ComparePointer(El,Pair.Orig);
  251. end;
  252. { TCustomTestPrecompile }
  253. procedure TCustomTestPrecompile.OnFilerGetSrc(Sender: TObject;
  254. aFilename: string; out p: PChar; out Count: integer);
  255. var
  256. i: Integer;
  257. aModule: TTestEnginePasResolver;
  258. Src: String;
  259. begin
  260. for i:=0 to ResolverCount-1 do
  261. begin
  262. aModule:=Resolvers[i];
  263. if aModule.Filename<>aFilename then continue;
  264. Src:=aModule.Source;
  265. p:=PChar(Src);
  266. Count:=length(Src);
  267. end;
  268. end;
  269. function TCustomTestPrecompile.OnConverterIsElementUsed(Sender: TObject;
  270. El: TPasElement): boolean;
  271. begin
  272. Result:=Analyzer.IsUsed(El);
  273. end;
  274. function TCustomTestPrecompile.OnConverterIsTypeInfoUsed(Sender: TObject;
  275. El: TPasElement): boolean;
  276. begin
  277. Result:=Analyzer.IsTypeInfoUsed(El);
  278. end;
  279. function TCustomTestPrecompile.OnRestConverterIsElementUsed(Sender: TObject;
  280. El: TPasElement): boolean;
  281. begin
  282. Result:=RestAnalyzer.IsUsed(El);
  283. end;
  284. function TCustomTestPrecompile.OnRestConverterIsTypeInfoUsed(Sender: TObject;
  285. El: TPasElement): boolean;
  286. begin
  287. Result:=RestAnalyzer.IsTypeInfoUsed(El);
  288. end;
  289. function TCustomTestPrecompile.OnRestResolverFindUnit(const aUnitName: String
  290. ): TPasModule;
  291. function FindRestUnit(Name: string): TPasModule;
  292. var
  293. i: Integer;
  294. CurEngine: TTestEnginePasResolver;
  295. CurUnitName: String;
  296. begin
  297. for i:=0 to ResolverCount-1 do
  298. begin
  299. CurEngine:=Resolvers[i];
  300. CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
  301. {$IFDEF VerbosePCUFiler}
  302. //writeln('TCustomTestPrecompile.FindRestUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
  303. {$ENDIF}
  304. if CompareText(Name,CurUnitName)=0 then
  305. begin
  306. Result:=CurEngine.Module;
  307. if Result<>nil then
  308. begin
  309. {$IFDEF VerbosePCUFiler}
  310. //writeln('TCustomTestPrecompile.FindRestUnit Found parsed module: ',Result.Filename);
  311. {$ENDIF}
  312. exit;
  313. end;
  314. {$IFDEF VerbosePCUFiler}
  315. writeln('TCustomTestPrecompile.FindRestUnit PARSING unit "',CurEngine.Filename,'"');
  316. {$ENDIF}
  317. Fail('not parsed');
  318. end;
  319. end;
  320. end;
  321. var
  322. DefNamespace: String;
  323. begin
  324. if (Pos('.',aUnitName)<1) then
  325. begin
  326. DefNamespace:=GetDefaultNamespace;
  327. if DefNamespace<>'' then
  328. begin
  329. Result:=FindRestUnit(DefNamespace+'.'+aUnitName);
  330. if Result<>nil then exit;
  331. end;
  332. end;
  333. Result:=FindRestUnit(aUnitName);
  334. end;
  335. procedure TCustomTestPrecompile.SetUp;
  336. begin
  337. inherited SetUp;
  338. FInitialFlags:=TPCUInitialFlags.Create;
  339. FAnalyzer:=TPas2JSAnalyzer.Create;
  340. FCheckedElements:=TPasAnalyzerKeySet.Create(@CompareCheckedElementPairs,@CompareElWithCheckedElementPair);
  341. Analyzer.Resolver:=ResolverEngine;
  342. Analyzer.Options:=Analyzer.Options+[paoImplReferences];
  343. Converter.OnIsElementUsed:=@OnConverterIsElementUsed;
  344. Converter.OnIsTypeInfoUsed:=@OnConverterIsTypeInfoUsed;
  345. end;
  346. procedure TCustomTestPrecompile.TearDown;
  347. begin
  348. if FCheckedElements<>nil then
  349. begin
  350. FCheckedElements.FreeItems;
  351. FreeAndNil(FCheckedElements);
  352. end;
  353. FreeAndNil(FAnalyzer);
  354. FreeAndNil(FPCUWriter);
  355. FreeAndNil(FPCUReader);
  356. FreeAndNil(FInitialFlags);
  357. inherited TearDown;
  358. end;
  359. function TCustomTestPrecompile.CreateConverter: TPasToJSConverter;
  360. begin
  361. Result:=inherited CreateConverter;
  362. Result.Options:=Result.Options+[coStoreImplJS];
  363. end;
  364. procedure TCustomTestPrecompile.ParseUnit;
  365. begin
  366. inherited ParseUnit;
  367. Analyzer.AnalyzeModule(Module);
  368. end;
  369. procedure TCustomTestPrecompile.WriteReadUnit;
  370. var
  371. ms: TMemoryStream;
  372. PCU, RestJSSrc, OrigJSSrc: string;
  373. // restored classes:
  374. RestResolver: TTestEnginePasResolver;
  375. RestFileResolver: TFileResolver;
  376. RestScanner: TPas2jsPasScanner;
  377. RestParser: TPasParser;
  378. RestConverter: TPasToJSConverter;
  379. RestJSModule: TJSSourceElements;
  380. InitialParserOptions: TPOptions;
  381. begin
  382. InitialParserOptions:=Parser.Options;
  383. Analyzer.Options:=Analyzer.Options+[paoSkipGenericProc];
  384. Converter.Options:=Converter.Options+[coShortRefGlobals];
  385. ConvertUnit;
  386. FPCUWriter:=TPCUWriter.Create;
  387. FPCUReader:=TPCUReader.Create;
  388. ms:=TMemoryStream.Create;
  389. RestParser:=nil;
  390. RestScanner:=nil;
  391. RestResolver:=nil;
  392. RestFileResolver:=nil;
  393. RestConverter:=nil;
  394. RestJSModule:=nil;
  395. try
  396. try
  397. PCUWriter.OnGetSrc:=@OnFilerGetSrc;
  398. PCUWriter.OnIsElementUsed:=@OnConverterIsElementUsed;
  399. PCUWriter.WritePCU(ResolverEngine,Converter,InitialFlags,ms,false);
  400. except
  401. on E: Exception do
  402. begin
  403. {$IFDEF VerbosePas2JS}
  404. writeln('TCustomTestPrecompile.WriteReadUnit WRITE failed');
  405. {$ENDIF}
  406. Fail('Write failed('+E.ClassName+'): '+E.Message);
  407. end;
  408. end;
  409. try
  410. PCU:='';
  411. SetLength(PCU,ms.Size);
  412. System.Move(ms.Memory^,PCU[1],length(PCU));
  413. writeln('TCustomTestPrecompile.WriteReadUnit PCU START-----');
  414. writeln(PCU);
  415. writeln('TCustomTestPrecompile.WriteReadUnit PCU END-------');
  416. RestFileResolver:=TFileResolver.Create;
  417. RestScanner:=TPas2jsPasScanner.Create(RestFileResolver);
  418. InitScanner(RestScanner);
  419. RestResolver:=TTestEnginePasResolver.Create;
  420. RestResolver.Filename:=ResolverEngine.Filename;
  421. RestResolver.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
  422. RestResolver.OnFindUnit:=@OnRestResolverFindUnit;
  423. RestParser:=TPasParser.Create(RestScanner,RestFileResolver,RestResolver);
  424. RestParser.Options:=InitialParserOptions;
  425. RestResolver.CurrentParser:=RestParser;
  426. ms.Position:=0;
  427. PCUReader.ReadPCU(RestResolver,ms);
  428. if not PCUReader.ReadContinue then
  429. Fail('ReadContinue=false, pending used interfaces');
  430. except
  431. on E: Exception do
  432. begin
  433. {$IFDEF VerbosePas2JS}
  434. writeln('TCustomTestPrecompile.WriteReadUnit READ failed');
  435. {$ENDIF}
  436. Fail('Read failed('+E.ClassName+'): '+E.Message);
  437. end;
  438. end;
  439. // analyze
  440. FRestAnalyzer:=TPas2JSAnalyzer.Create;
  441. FRestAnalyzer.Resolver:=RestResolver;
  442. FRestAnalyzer.Options:=FRestAnalyzer.Options+[paoSkipGenericProc];
  443. try
  444. RestAnalyzer.AnalyzeModule(RestResolver.RootElement);
  445. except
  446. on E: Exception do
  447. begin
  448. {$IFDEF VerbosePas2JS}
  449. writeln('TCustomTestPrecompile.WriteReadUnit ANALYZEMODULE failed');
  450. {$ENDIF}
  451. Fail('AnalyzeModule precompiled failed('+E.ClassName+'): '+E.Message);
  452. end;
  453. end;
  454. // check parser+resolver+analyzer
  455. CheckRestoredResolver(ResolverEngine,RestResolver,[]);
  456. // convert using the precompiled procs
  457. RestConverter:=CreateConverter;
  458. RestConverter.Options:=Converter.Options;
  459. RestConverter.OnIsElementUsed:=@OnRestConverterIsElementUsed;
  460. RestConverter.OnIsTypeInfoUsed:=@OnRestConverterIsTypeInfoUsed;
  461. try
  462. RestJSModule:=RestConverter.ConvertPasElement(RestResolver.RootElement,RestResolver) as TJSSourceElements;
  463. except
  464. on E: Exception do
  465. begin
  466. {$IFDEF VerbosePas2JS}
  467. writeln('TCustomTestPrecompile.WriteReadUnit CONVERTER failed');
  468. {$ENDIF}
  469. Fail('Convert precompiled failed('+E.ClassName+'): '+E.Message);
  470. end;
  471. end;
  472. OrigJSSrc:=JSToStr(JSModule);
  473. RestJSSrc:=JSToStr(RestJSModule);
  474. if OrigJSSrc<>RestJSSrc then
  475. begin
  476. writeln('TCustomTestPrecompile.WriteReadUnit OrigJSSrc:---------START');
  477. writeln(OrigJSSrc);
  478. writeln('TCustomTestPrecompile.WriteReadUnit OrigJSSrc:---------END');
  479. writeln('TCustomTestPrecompile.WriteReadUnit RestJSSrc:---------START');
  480. writeln(RestJSSrc);
  481. writeln('TCustomTestPrecompile.WriteReadUnit RestJSSrc:---------END');
  482. CheckDiff('WriteReadUnit JS diff',OrigJSSrc,RestJSSrc);
  483. end;
  484. finally
  485. RestJSModule.Free;
  486. RestConverter.Free;
  487. FreeAndNil(FRestAnalyzer);
  488. RestParser.Free;
  489. RestScanner.Free;
  490. RestResolver.Free; // free parser before resolver
  491. RestFileResolver.Free;
  492. ms.Free;
  493. end;
  494. end;
  495. procedure TCustomTestPrecompile.StartParsing;
  496. begin
  497. inherited StartParsing;
  498. FInitialFlags.ParserOptions:=Parser.Options;
  499. FInitialFlags.ModeSwitches:=Scanner.CurrentModeSwitches;
  500. FInitialFlags.BoolSwitches:=Scanner.CurrentBoolSwitches;
  501. FInitialFlags.ConverterOptions:=Converter.Options;
  502. FInitialFlags.TargetPlatform:=Converter.Globals.TargetPlatform;
  503. FInitialFlags.TargetProcessor:=Converter.Globals.TargetProcessor;
  504. // ToDo: defines
  505. end;
  506. function TCustomTestPrecompile.CheckRestoredObject(const Path: string; Orig,
  507. Rest: TObject): boolean;
  508. begin
  509. if Orig=nil then
  510. begin
  511. if Rest<>nil then
  512. Fail(Path+': Orig=nil Rest='+GetObjPath(Rest));
  513. exit(false);
  514. end
  515. else if Rest=nil then
  516. Fail(Path+': Orig='+GetObjPath(Orig)+' Rest=nil');
  517. if Orig.ClassType<>Rest.ClassType then
  518. Fail(Path+': Orig='+GetObjPath(Orig)+' Rest='+GetObjPath(Rest));
  519. Result:=true;
  520. end;
  521. procedure TCustomTestPrecompile.CheckRestoredJS(const Path, Orig, Rest: string);
  522. var
  523. OrigList, RestList: TStringList;
  524. begin
  525. if Orig=Rest then exit;
  526. writeln('TCustomTestPrecompile.CheckRestoredJS ORIG START--------------');
  527. writeln(Orig);
  528. writeln('TCustomTestPrecompile.CheckRestoredJS ORIG END----------------');
  529. writeln('TCustomTestPrecompile.CheckRestoredJS REST START--------------');
  530. writeln(Rest);
  531. writeln('TCustomTestPrecompile.CheckRestoredJS REST END----------------');
  532. OrigList:=TStringList.Create;
  533. RestList:=TStringList.Create;
  534. try
  535. OrigList.Text:=Orig;
  536. RestList.Text:=Rest;
  537. CheckRestoredStringList(Path,OrigList,RestList);
  538. finally
  539. OrigList.Free;
  540. RestList.Free;
  541. end;
  542. end;
  543. procedure TCustomTestPrecompile.CheckRestoredStringList(const Path: string;
  544. Orig, Rest: TStrings);
  545. var
  546. i: Integer;
  547. begin
  548. CheckRestoredObject(Path,Orig,Rest);
  549. if Orig=nil then exit;
  550. if Orig.Text=Rest.Text then exit;
  551. for i:=0 to Orig.Count-1 do
  552. begin
  553. if i>=Rest.Count then
  554. Fail(Path+' missing: '+Orig[i]);
  555. writeln(' ',i,': '+Orig[i]);
  556. end;
  557. if Orig.Count<Rest.Count then
  558. Fail(Path+' too much: '+Rest[Orig.Count]);
  559. end;
  560. procedure TCustomTestPrecompile.CheckRestoredResolver(Original,
  561. Restored: TPas2JSResolver; Flags: TPCCheckFlags);
  562. var
  563. OrigParser, RestParser: TPasParser;
  564. begin
  565. AssertNotNull('CheckRestoredResolver Original',Original);
  566. AssertNotNull('CheckRestoredResolver Restored',Restored);
  567. if Original.ClassType<>Restored.ClassType then
  568. Fail('CheckRestoredResolver Original='+Original.ClassName+' Restored='+Restored.ClassName);
  569. CheckRestoredElement('RootElement',Original.RootElement,Restored.RootElement,Flags);
  570. OrigParser:=Original.CurrentParser;
  571. RestParser:=Restored.CurrentParser;
  572. if OrigParser.Options<>RestParser.Options then
  573. Fail('CheckRestoredResolver Parser.Options');
  574. if OrigParser.Scanner.CurrentBoolSwitches<>RestParser.Scanner.CurrentBoolSwitches then
  575. Fail('CheckRestoredResolver Scanner.BoolSwitches');
  576. if OrigParser.Scanner.CurrentModeSwitches<>RestParser.Scanner.CurrentModeSwitches then
  577. Fail('CheckRestoredResolver Scanner.ModeSwitches');
  578. end;
  579. procedure TCustomTestPrecompile.CheckRestoredDeclarations(const Path: string;
  580. Orig, Rest: TPasDeclarations; Flags: TPCCheckFlags);
  581. function IsSpecialization(El: TPasElement): boolean;
  582. begin
  583. Result:=(El.CustomData is TPasGenericScope)
  584. and (TPasGenericScope(El.CustomData).SpecializedFromItem<>nil);
  585. end;
  586. function GetSubPath(const Path: string; OrigIndex: integer; OrigDecl: TPasElement): string;
  587. begin
  588. Result:=Path+'['+IntToStr(OrigIndex)+']';
  589. if OrigDecl.Name<>'' then
  590. Result:=Result+'"'+OrigDecl.Name+'"'
  591. else
  592. Result:=Result+'?noname?';
  593. end;
  594. { procedure WriteList;
  595. var
  596. i: Integer;
  597. begin
  598. writeln('CheckRestoredDeclarations.WriteList');
  599. for i:=0 to Orig.Declarations.Count-1 do
  600. if i<Rest.Declarations.Count then
  601. writeln(' ',i,' Orig=',TPasElement(Orig.Declarations[i]).Name,' Rest=',TPasElement(Rest.Declarations[i]).Name);
  602. end;}
  603. var
  604. OrigIndex, RestIndex: Integer;
  605. OrigDecl, RestDecl: TPasElement;
  606. SubPath: String;
  607. begin
  608. //WriteList;
  609. // check non specializations
  610. RestIndex:=0;
  611. for OrigIndex:=0 to Orig.Declarations.Count-1 do
  612. begin
  613. OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
  614. if IsSpecialization(OrigDecl) then
  615. continue;
  616. SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
  617. // skip to next non specialization in restored declarations
  618. while RestIndex<Rest.Declarations.Count do
  619. begin
  620. RestDecl:=TPasElement(Rest.Declarations[RestIndex]);
  621. if not IsSpecialization(RestDecl) then
  622. break;
  623. inc(RestIndex)
  624. end;
  625. if RestIndex=Rest.Declarations.Count then
  626. Fail(SubPath+' missing in restored Declarations');
  627. // check
  628. CheckRestoredElement(SubPath,OrigDecl,RestDecl,Flags);
  629. inc(RestIndex);
  630. end;
  631. // check specializations
  632. for OrigIndex:=0 to Orig.Declarations.Count-1 do
  633. begin
  634. OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
  635. if not IsSpecialization(OrigDecl) then
  636. continue;
  637. SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
  638. // search specialization with same name
  639. RestIndex:=0;
  640. repeat
  641. if RestIndex=Rest.Declarations.Count then
  642. Fail(SubPath+' missing in restored Declarations');
  643. RestDecl:=TPasElement(Rest.Declarations[RestIndex]);
  644. if IsSpecialization(RestDecl) and (OrigDecl.Name=RestDecl.Name) then
  645. break;
  646. inc(RestIndex);
  647. until false;
  648. if (OrigIndex<Rest.Declarations.Count) and (OrigIndex<>RestIndex) then
  649. begin
  650. // move restored element to original place to generate the same JS
  651. //writeln('TCustomTestPrecompile.CheckRestoredDeclarations Orig[',OrigIndex,']=',GetObjName(OrigDecl),' Rest[',RestIndex,']=',GetObjName(RestDecl));
  652. if RestIndex>OrigIndex then
  653. Rest.Declarations.Move(RestIndex,OrigIndex)
  654. else
  655. Rest.Declarations.Exchange(RestIndex,OrigIndex);
  656. //writeln('TCustomTestPrecompile.CheckRestoredDeclarations RestIndex=',RestIndex,' ->',OrigIndex);
  657. //WriteList;
  658. end;
  659. // check
  660. CheckRestoredElement(SubPath,OrigDecl,RestDecl,Flags);
  661. end;
  662. AssertEquals(Path+'.Declarations.Count',Orig.Declarations.Count,Rest.Declarations.Count);
  663. //WriteList;
  664. for OrigIndex:=0 to Orig.Declarations.Count-1 do
  665. begin
  666. OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
  667. RestDecl:=TPasElement(Rest.Declarations[OrigIndex]);
  668. if OrigDecl.Name<>RestDecl.Name then
  669. begin
  670. SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
  671. AssertEquals(SubPath+'.Name',GetObjPath(OrigDecl),GetObjPath(RestDecl));
  672. end;
  673. end;
  674. end;
  675. procedure TCustomTestPrecompile.CheckRestoredSection(const Path: string; Orig,
  676. Rest: TPasSection; Flags: TPCCheckFlags);
  677. begin
  678. if length(Orig.UsesClause)>0 then
  679. ; // ToDo
  680. CheckRestoredDeclarations(Path,Orig,Rest,Flags);
  681. end;
  682. procedure TCustomTestPrecompile.CheckRestoredModule(const Path: string; Orig,
  683. Rest: TPasModule; Flags: TPCCheckFlags);
  684. procedure CheckInitFinal(const Path: string; OrigBlock, RestBlock: TPasImplBlock);
  685. begin
  686. CheckRestoredObject(Path,OrigBlock,RestBlock);
  687. if OrigBlock=nil then exit;
  688. CheckRestoredCustomData(Path+'.CustomData',RestBlock,OrigBlock.CustomData,RestBlock.CustomData,Flags);
  689. end;
  690. begin
  691. if not (Orig.CustomData is TPas2JSModuleScope) then
  692. Fail(Path+'.CustomData is not TPasModuleScope'+GetObjName(Orig.CustomData));
  693. CheckRestoredElement(Path+'.InterfaceSection',Orig.InterfaceSection,Rest.InterfaceSection,Flags);
  694. CheckRestoredElement(Path+'.ImplementationSection',Orig.ImplementationSection,Rest.ImplementationSection,Flags);
  695. if Orig is TPasProgram then
  696. CheckRestoredElement(Path+'.ProgramSection',TPasProgram(Orig).ProgramSection,TPasProgram(Rest).ProgramSection,Flags)
  697. else if Orig is TPasLibrary then
  698. CheckRestoredElement(Path+'.LibrarySection',TPasLibrary(Orig).LibrarySection,TPasLibrary(Rest).LibrarySection,Flags);
  699. CheckInitFinal(Path+'.InitializationSection',Orig.InitializationSection,Rest.InitializationSection);
  700. CheckInitFinal(Path+'.FnializationSection',Orig.FinalizationSection,Rest.FinalizationSection);
  701. end;
  702. procedure TCustomTestPrecompile.CheckRestoredScopeReference(const Path: string;
  703. Orig, Rest: TPasScope; Flags: TPCCheckFlags);
  704. begin
  705. if not CheckRestoredObject(Path,Orig,Rest) then exit;
  706. CheckRestoredReference(Path+'.Element',Orig.Element,Rest.Element);
  707. if Flags=[] then ;
  708. end;
  709. procedure TCustomTestPrecompile.CheckRestoredElementBase(const Path: string;
  710. Orig, Rest: TPasElementBase; Flags: TPCCheckFlags);
  711. begin
  712. CheckRestoredObject(Path+'.CustomData',Orig.CustomData,Rest.CustomData);
  713. if Flags=[] then ;
  714. end;
  715. procedure TCustomTestPrecompile.CheckRestoredResolveData(const Path: string;
  716. Orig, Rest: TResolveData; Flags: TPCCheckFlags);
  717. begin
  718. CheckRestoredElementBase(Path,Orig,Rest,Flags);
  719. end;
  720. procedure TCustomTestPrecompile.CheckRestoredPasScope(const Path: string; Orig,
  721. Rest: TPasScope; Flags: TPCCheckFlags);
  722. begin
  723. CheckRestoredReference(Path+'.VisibilityContext',Orig.VisibilityContext,Rest.VisibilityContext);
  724. CheckRestoredResolveData(Path,Orig,Rest,Flags);
  725. end;
  726. procedure TCustomTestPrecompile.CheckRestoredLocalVar(const Path: string; Orig,
  727. Rest: TPas2JSStoredLocalVar);
  728. begin
  729. AssertEquals(Path+'.Name',Orig.Name,Rest.Name);
  730. CheckRestoredReference(Path+'.Id',Orig.Element,Rest.Element);
  731. end;
  732. procedure TCustomTestPrecompile.CheckRestoredModuleScope(const Path: string;
  733. Orig, Rest: TPas2JSModuleScope; Flags: TPCCheckFlags);
  734. var
  735. OrigLocalVars, RestLocalVars: TPas2JSStoredLocalVarArray;
  736. i, j: Integer;
  737. OrigLocalVar, RestLocalVar: TPas2JSStoredLocalVar;
  738. begin
  739. AssertEquals(Path+'.FirstName',Orig.FirstName,Rest.FirstName);
  740. if Orig.Flags<>Rest.Flags then
  741. Fail(Path+'.Flags');
  742. if Orig.BoolSwitches<>Rest.BoolSwitches then
  743. Fail(Path+'.BoolSwitches');
  744. CheckRestoredReference(Path+'.AssertClass',Orig.AssertClass,Rest.AssertClass);
  745. CheckRestoredReference(Path+'.AssertDefConstructor',Orig.AssertDefConstructor,Rest.AssertDefConstructor);
  746. CheckRestoredReference(Path+'.AssertMsgConstructor',Orig.AssertMsgConstructor,Rest.AssertMsgConstructor);
  747. CheckRestoredReference(Path+'.RangeErrorClass',Orig.RangeErrorClass,Rest.RangeErrorClass);
  748. CheckRestoredReference(Path+'.RangeErrorConstructor',Orig.RangeErrorConstructor,Rest.RangeErrorConstructor);
  749. CheckRestoredReference(Path+'.SystemTVarRec',Orig.SystemTVarRec,Rest.SystemTVarRec);
  750. CheckRestoredReference(Path+'.SystemVarRecs',Orig.SystemVarRecs,Rest.SystemVarRecs);
  751. // StoreJSLocalVars
  752. OrigLocalVars:=Orig.StoreJSLocalVars;
  753. RestLocalVars:=Rest.StoreJSLocalVars;
  754. //for i:=0 to length(RestLocalVars)-1 do
  755. // writeln('TCustomTestPrecompile.CheckRestoredModuleScope Rest ',i,'/',length(RestLocalVars),' ',RestLocalVars[i].Name);
  756. for i:=0 to length(OrigLocalVars)-1 do
  757. begin
  758. OrigLocalVar:=OrigLocalVars[i];
  759. //writeln('TCustomTestPrecompile.CheckRestoredModuleScope Orig ',i,'/',length(OrigLocalVars),' ',OrigLocalVar.Name);
  760. j:=length(OrigLocalVars)-1;
  761. while (j>=0) do
  762. begin
  763. RestLocalVar:=RestLocalVars[j];
  764. if OrigLocalVar.Name=RestLocalVar.Name then
  765. begin
  766. CheckRestoredLocalVar(Path+'.LocalVars['+IntToStr(i)+']',OrigLocalVar,RestLocalVar);
  767. break;
  768. end;
  769. dec(j);
  770. end;
  771. if j<0 then
  772. Fail(Path+'.LocalVars['+IntToStr(i)+'] Name="'+OrigLocalVar.Name+'" missing in Rest');
  773. end;
  774. AssertEquals('LocalVars.Count',length(OrigLocalVars),length(RestLocalVars));
  775. CheckRestoredPasScope(Path,Orig,Rest,Flags);
  776. end;
  777. procedure TCustomTestPrecompile.CheckRestoredIdentifierScope(
  778. const Path: string; Orig, Rest: TPasIdentifierScope; Flags: TPCCheckFlags);
  779. var
  780. OrigList: TFPList;
  781. i: Integer;
  782. OrigIdentifier, RestIdentifier: TPasIdentifier;
  783. begin
  784. OrigList:=nil;
  785. try
  786. OrigList:=Orig.GetLocalIdentifiers;
  787. for i:=0 to OrigList.Count-1 do
  788. begin
  789. OrigIdentifier:=TPasIdentifier(OrigList[i]);
  790. RestIdentifier:=Rest.FindLocalIdentifier(OrigIdentifier.Identifier);
  791. if RestIdentifier=nil then
  792. Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Missing RestIdentifier Orig='+OrigIdentifier.Identifier);
  793. repeat
  794. AssertEquals(Path+'.Local.Identifier',OrigIdentifier.Identifier,RestIdentifier.Identifier);
  795. CheckRestoredReference(Path+'.Local',OrigIdentifier.Element,RestIdentifier.Element);
  796. if OrigIdentifier.Kind<>RestIdentifier.Kind then
  797. Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Orig='+PCUIdentifierKindNames[OrigIdentifier.Kind]+' Rest='+PCUIdentifierKindNames[RestIdentifier.Kind]);
  798. if OrigIdentifier.NextSameIdentifier=nil then
  799. begin
  800. if RestIdentifier.NextSameIdentifier<>nil then
  801. Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Too many RestIdentifier.NextSameIdentifier='+GetObjName(RestIdentifier.Element));
  802. break;
  803. end
  804. else begin
  805. if RestIdentifier.NextSameIdentifier=nil then
  806. Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Missing RestIdentifier.NextSameIdentifier Orig='+GetObjName(OrigIdentifier.NextSameIdentifier.Element));
  807. end;
  808. if CompareText(OrigIdentifier.Identifier,OrigIdentifier.NextSameIdentifier.Identifier)<>0 then
  809. Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Cur.Identifier<>Next.Identifier '+OrigIdentifier.Identifier+'<>'+OrigIdentifier.NextSameIdentifier.Identifier);
  810. OrigIdentifier:=OrigIdentifier.NextSameIdentifier;
  811. RestIdentifier:=RestIdentifier.NextSameIdentifier;
  812. until false;
  813. end;
  814. finally
  815. OrigList.Free;
  816. end;
  817. CheckRestoredPasScope(Path,Orig,Rest,Flags);
  818. end;
  819. procedure TCustomTestPrecompile.CheckRestoredSectionScope(const Path: string;
  820. Orig, Rest: TPas2JSSectionScope; Flags: TPCCheckFlags);
  821. var
  822. i: Integer;
  823. OrigUses, RestUses: TPas2JSSectionScope;
  824. OrigHelperEntry, RestHelperEntry: TPRHelperEntry;
  825. begin
  826. if Orig.BoolSwitches<>Rest.BoolSwitches then
  827. Fail(Path+'.BoolSwitches Orig='+BoolSwitchesToStr(Orig.BoolSwitches)+' Rest='+BoolSwitchesToStr(Rest.BoolSwitches));
  828. if Orig.ModeSwitches<>Rest.ModeSwitches then
  829. Fail(Path+'.ModeSwitches');
  830. AssertEquals(Path+' UsesScopes.Count',Orig.UsesScopes.Count,Rest.UsesScopes.Count);
  831. for i:=0 to Orig.UsesScopes.Count-1 do
  832. begin
  833. OrigUses:=TPas2JSSectionScope(Orig.UsesScopes[i]);
  834. if not (TObject(Rest.UsesScopes[i]) is TPas2JSSectionScope) then
  835. Fail(Path+'.UsesScopes['+IntToStr(i)+'] Rest='+GetObjName(TObject(Rest.UsesScopes[i])));
  836. RestUses:=TPas2JSSectionScope(Rest.UsesScopes[i]);
  837. if OrigUses.ClassType<>RestUses.ClassType then
  838. Fail(Path+'.UsesScopes['+IntToStr(i)+'] Orig='+GetObjName(OrigUses)+' Rest='+GetObjName(RestUses));
  839. CheckRestoredReference(Path+'.UsesScopes['+IntToStr(i)+']',OrigUses.Element,RestUses.Element);
  840. end;
  841. AssertEquals(Path+' length(Helpers)',length(Orig.Helpers),length(Rest.Helpers));
  842. for i:=0 to length(Orig.Helpers)-1 do
  843. begin
  844. OrigHelperEntry:=TPRHelperEntry(Orig.Helpers[i]);
  845. RestHelperEntry:=TPRHelperEntry(Rest.Helpers[i]);
  846. if OrigHelperEntry.ClassType<>RestHelperEntry.ClassType then
  847. Fail(Path+'.Helpers['+IntToStr(i)+'] Orig='+GetObjName(OrigHelperEntry)+' Rest='+GetObjName(RestHelperEntry));
  848. AssertEquals(Path+'.Helpers['+IntToStr(i)+'].Added',OrigHelperEntry.Added,RestHelperEntry.Added);
  849. CheckRestoredReference(Path+'.Helpers['+IntToStr(i)+'].Helper',OrigHelperEntry.Helper,RestHelperEntry.Helper);
  850. CheckRestoredReference(Path+'.Helpers['+IntToStr(i)+'].HelperForType',OrigHelperEntry.HelperForType,RestHelperEntry.HelperForType);
  851. end;
  852. AssertEquals(Path+'.Finished',Orig.Finished,Rest.Finished);
  853. CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
  854. end;
  855. procedure TCustomTestPrecompile.CheckRestoredInitialFinalizationScope(
  856. const Path: string; Orig, Rest: TPas2JSInitialFinalizationScope;
  857. Flags: TPCCheckFlags);
  858. begin
  859. CheckRestoredScopeRefs(Path+'.References',Orig.References,Rest.References,Flags);
  860. CheckRestoredPrecompiledJS(Path+'.ImplJS',Orig.Element,Orig.ImplJS,Rest.Element,Rest.ImplJS,Flags);
  861. end;
  862. procedure TCustomTestPrecompile.CheckRestoredEnumTypeScope(const Path: string;
  863. Orig, Rest: TPasEnumTypeScope; Flags: TPCCheckFlags);
  864. begin
  865. CheckRestoredReference(Path+'.CanonicalSet',Orig.CanonicalSet,Rest.CanonicalSet);
  866. CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
  867. end;
  868. procedure TCustomTestPrecompile.CheckRestoredRecordScope(const Path: string;
  869. Orig, Rest: TPas2jsRecordScope; Flags: TPCCheckFlags);
  870. begin
  871. CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
  872. CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
  873. // ok -> use same JSName
  874. Rest.JSName:=Orig.JSName;
  875. end;
  876. procedure TCustomTestPrecompile.CheckRestoredClassScope(const Path: string;
  877. Orig, Rest: TPas2JSClassScope; Flags: TPCCheckFlags);
  878. var
  879. i, j: Integer;
  880. OrigObj, RestObj: TObject;
  881. OrigMap, RestMap: TPasClassIntfMap;
  882. SubPath: String;
  883. begin
  884. CheckRestoredScopeReference(Path+'.AncestorScope',Orig.AncestorScope,Rest.AncestorScope,Flags);
  885. CheckRestoredElement(Path+'.CanonicalClassOf',Orig.CanonicalClassOf,Rest.CanonicalClassOf,Flags);
  886. CheckRestoredReference(Path+'.DirectAncestor',Orig.DirectAncestor,Rest.DirectAncestor);
  887. CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
  888. if Orig.Flags<>Rest.Flags then
  889. Fail(Path+'.Flags');
  890. AssertEquals(Path+'.AbstractProcs.length',length(Orig.AbstractProcs),length(Rest.AbstractProcs));
  891. for i:=0 to length(Orig.AbstractProcs)-1 do
  892. CheckRestoredReference(Path+'.AbstractProcs['+IntToStr(i)+']',Orig.AbstractProcs[i],Rest.AbstractProcs[i]);
  893. CheckRestoredReference(Path+'.NewInstanceFunction',Orig.NewInstanceFunction,Rest.NewInstanceFunction);
  894. AssertEquals(Path+'.GUID',Orig.GUID,Rest.GUID);
  895. AssertEquals(Path+'.DispatchField',Orig.DispatchField,Rest.DispatchField);
  896. AssertEquals(Path+'.DispatchStrField',Orig.DispatchStrField,Rest.DispatchStrField);
  897. CheckRestoredObject('.Interfaces',Orig.Interfaces,Rest.Interfaces);
  898. if Orig.Interfaces<>nil then
  899. begin
  900. AssertEquals(Path+'.Interfaces.Count',Orig.Interfaces.Count,Rest.Interfaces.Count);
  901. for i:=0 to Orig.Interfaces.Count-1 do
  902. begin
  903. SubPath:=Path+'.Interfaces['+IntToStr(i)+']';
  904. OrigObj:=TObject(Orig.Interfaces[i]);
  905. RestObj:=TObject(Rest.Interfaces[i]);
  906. CheckRestoredObject(SubPath,OrigObj,RestObj);
  907. if OrigObj is TPasProperty then
  908. CheckRestoredReference(SubPath+'(TPasProperty)',
  909. TPasProperty(OrigObj),TPasProperty(RestObj))
  910. else if OrigObj is TPasClassIntfMap then
  911. begin
  912. OrigMap:=TPasClassIntfMap(OrigObj);
  913. RestMap:=TPasClassIntfMap(RestObj);
  914. repeat
  915. AssertNotNull(SubPath+'.Intf Orig',OrigMap.Intf);
  916. CheckRestoredObject(SubPath+'.Intf',OrigMap.Intf,RestMap.Intf);
  917. SubPath:=SubPath+'.Map('+OrigMap.Intf.Name+')';
  918. CheckRestoredObject(SubPath+'.Element',OrigMap.Element,RestMap.Element);
  919. CheckRestoredObject(SubPath+'.Procs',OrigMap.Procs,RestMap.Procs);
  920. if OrigMap.Procs=nil then
  921. begin
  922. if OrigMap.Intf.Members.Count>0 then
  923. Fail(SubPath+' expected '+IntToStr(OrigMap.Intf.Members.Count)+' procs, but Procs=nil');
  924. end
  925. else
  926. for j:=0 to OrigMap.Procs.Count-1 do
  927. begin
  928. OrigObj:=TObject(OrigMap.Procs[j]);
  929. RestObj:=TObject(RestMap.Procs[j]);
  930. CheckRestoredReference(SubPath+'.Procs['+IntToStr(j)+']',TPasElement(OrigObj),TPasElement(RestObj));
  931. end;
  932. AssertEquals(Path+'.Procs.Count',OrigMap.Procs.Count,RestMap.Procs.Count);
  933. CheckRestoredObject(SubPath+'.AncestorMap',OrigMap.AncestorMap,RestMap.AncestorMap);
  934. OrigMap:=OrigMap.AncestorMap;
  935. RestMap:=RestMap.AncestorMap;
  936. until OrigMap=nil;
  937. end
  938. else
  939. Fail(SubPath+' unknown class '+GetObjName(OrigObj));
  940. end;
  941. end;
  942. CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
  943. // ok -> use same JSName
  944. Rest.JSName:=Orig.JSName;
  945. end;
  946. procedure TCustomTestPrecompile.CheckRestoredProcScope(const Path: string;
  947. Orig, Rest: TPas2JSProcedureScope; Flags: TPCCheckFlags);
  948. var
  949. DeclProc: TPasProcedure;
  950. begin
  951. CheckRestoredReference(Path+'.DeclarationProc',Orig.DeclarationProc,Rest.DeclarationProc);
  952. CheckRestoredReference(Path+'.ImplProc',Orig.ImplProc,Rest.ImplProc);
  953. CheckRestoredPrecompiledJS(Path+'.ImplJS',Orig.Element,Orig.ImplJS,Rest.Element,Rest.ImplJS,Flags);
  954. if Rest.DeclarationProc=nil then
  955. begin
  956. DeclProc:=TPasProcedure(Rest.Element);
  957. AssertEquals(Path+'.ResultVarName',Orig.ResultVarName,Rest.ResultVarName);
  958. CheckRestoredReference(Path+'.OverriddenProc',Orig.OverriddenProc,Rest.OverriddenProc);
  959. CheckRestoredScopeReference(Path+'.ClassScope',Orig.ClassRecScope,Rest.ClassRecScope,Flags);
  960. CheckRestoredElement(Path+'.SelfArg',Orig.SelfArg,Rest.SelfArg,Flags);
  961. if Orig.Flags<>Rest.Flags then
  962. Fail(Path+'.Flags');
  963. if Orig.BoolSwitches<>Rest.BoolSwitches then
  964. Fail(Path+'.BoolSwitches');
  965. if Orig.ModeSwitches<>Rest.ModeSwitches then
  966. Fail(Path+'.ModeSwitches');
  967. if ResolverEngine.ProcCanBePrecompiled(DeclProc) then
  968. begin
  969. CheckRestoredScopeRefs(Path+'.References',Orig.References,Rest.References,Flags);
  970. end;
  971. //CheckRestoredIdentifierScope(Path,Orig,Rest);
  972. end
  973. else
  974. begin
  975. // ImplProc
  976. end;
  977. // ok -> use same JSName
  978. Rest.JSName:=Orig.JSName;
  979. end;
  980. procedure TCustomTestPrecompile.CheckRestoredProcTypeScope(const Path: string;
  981. Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags);
  982. begin
  983. if Path='' then ;
  984. if Flags=[] then ;
  985. // ok -> use same JSName
  986. Rest.JSName:=Orig.JSName;
  987. end;
  988. procedure TCustomTestPrecompile.CheckRestoredArrayScope(const Path: string;
  989. Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags);
  990. begin
  991. if Path='' then ;
  992. if Flags=[] then ;
  993. // ok -> use same JSName
  994. Rest.JSName:=Orig.JSName;
  995. end;
  996. procedure TCustomTestPrecompile.CheckRestoredPrecompiledJS(const Path: string;
  997. OrigEl: TPasElement; Orig: TPas2JSPrecompiledJS; RestEl: TPasElement;
  998. Rest: TPas2JSPrecompiledJS; Flags: TPCCheckFlags);
  999. begin
  1000. CheckRestoredObject(Path,Orig,Rest);
  1001. if Orig=nil then exit;
  1002. if Flags=[] then ;
  1003. AssertEquals(Path+'.EmptyJS',Orig.EmptyJS,Rest.EmptyJS);
  1004. if Orig.BodyJS<>Rest.BodyJS then
  1005. CheckRestoredJS(Path+'.BodyJS',Orig.BodyJS,Rest.BodyJS);
  1006. if Orig.BodyJS<>'' then
  1007. begin
  1008. CheckRestoredStringList(Path+'.GlobalJS',Orig.GlobalJS,Rest.GlobalJS);
  1009. CheckRestoredElRefList(Path+'.ShortRefs',OrigEl,Orig.ShortRefs,RestEl,Rest.ShortRefs,false,Flags);
  1010. end;
  1011. end;
  1012. procedure TCustomTestPrecompile.CheckRestoredScopeRefs(const Path: string;
  1013. Orig, Rest: TPasScopeReferences; Flags: TPCCheckFlags);
  1014. var
  1015. OrigList, RestList: TFPList;
  1016. i: Integer;
  1017. OrigRef, RestRef: TPasScopeReference;
  1018. ok: Boolean;
  1019. begin
  1020. if Flags=[] then ;
  1021. CheckRestoredObject(Path,Orig,Rest);
  1022. if Orig=nil then exit;
  1023. OrigList:=nil;
  1024. RestList:=nil;
  1025. ok:=false;
  1026. try
  1027. OrigList:=Orig.GetList;
  1028. RestList:=Rest.GetList;
  1029. OrigList.Sort(@CompareListOfProcScopeRef);
  1030. RestList.Sort(@CompareListOfProcScopeRef);
  1031. for i:=0 to OrigList.Count-1 do
  1032. begin
  1033. OrigRef:=TPasScopeReference(OrigList[i]);
  1034. if i>=RestList.Count then
  1035. Fail(Path+'['+IntToStr(i)+'] Missing in Rest: "'+OrigRef.Element.Name+'"');
  1036. RestRef:=TPasScopeReference(RestList[i]);
  1037. CheckRestoredReference(Path+'['+IntToStr(i)+'].Name="'+OrigRef.Element.Name+'"',OrigRef.Element,RestRef.Element);
  1038. if OrigRef.Access<>RestRef.Access then
  1039. AssertEquals(Path+'['+IntToStr(i)+']"'+OrigRef.Element.Name+'".Access',
  1040. PCUPSRefAccessNames[OrigRef.Access],PCUPSRefAccessNames[RestRef.Access]);
  1041. end;
  1042. if RestList.Count>OrigList.Count then
  1043. begin
  1044. i:=OrigList.Count;
  1045. RestRef:=TPasScopeReference(RestList[i]);
  1046. Fail(Path+'['+IntToStr(i)+'] Too many in Rest: "'+RestRef.Element.Name+'"');
  1047. end;
  1048. ok:=true;
  1049. finally
  1050. if not ok then
  1051. begin
  1052. for i:=0 to OrigList.Count-1 do
  1053. begin
  1054. OrigRef:=TPasScopeReference(OrigList[i]);
  1055. writeln('TCustomTestPrecompile.CheckRestoredScopeRefs Orig[',i,']=',GetObjPath(OrigRef.Element));
  1056. end;
  1057. for i:=0 to RestList.Count-1 do
  1058. begin
  1059. RestRef:=TPasScopeReference(RestList[i]);
  1060. writeln('TCustomTestPrecompile.CheckRestoredScopeRefs Rest[',i,']=',GetObjPath(RestRef.Element));
  1061. end;
  1062. end;
  1063. OrigList.Free;
  1064. RestList.Free;
  1065. end;
  1066. end;
  1067. procedure TCustomTestPrecompile.CheckRestoredPropertyScope(const Path: string;
  1068. Orig, Rest: TPasPropertyScope; Flags: TPCCheckFlags);
  1069. begin
  1070. CheckRestoredReference(Path+'.AncestorProp',Orig.AncestorProp,Rest.AncestorProp);
  1071. CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
  1072. end;
  1073. procedure TCustomTestPrecompile.CheckRestoredGenericParamScope(
  1074. const Path: string; Orig, Rest: TPasGenericParamsScope; Flags: TPCCheckFlags);
  1075. begin
  1076. // Orig.GenericType only needed during parsing
  1077. if Path='' then ;
  1078. if Orig<>nil then ;
  1079. if Rest<>nil then ;
  1080. if Flags=[] then ;
  1081. end;
  1082. procedure TCustomTestPrecompile.CheckRestoredSpecializeTypeData(
  1083. const Path: string; Orig, Rest: TPasSpecializeTypeData; Flags: TPCCheckFlags);
  1084. begin
  1085. if Flags<>[] then ;
  1086. CheckRestoredReference(Path+'.SpecializedType',Orig.SpecializedType,Rest.SpecializedType);
  1087. end;
  1088. procedure TCustomTestPrecompile.CheckRestoredResolvedReference(
  1089. const Path: string; Orig, Rest: TResolvedReference; Flags: TPCCheckFlags);
  1090. var
  1091. C: TClass;
  1092. begin
  1093. if Orig.Flags<>Rest.Flags then
  1094. Fail(Path+'.Flags');
  1095. if Orig.Access<>Rest.Access then
  1096. AssertEquals(Path+'.Access',PCUResolvedRefAccessNames[Orig.Access],PCUResolvedRefAccessNames[Rest.Access]);
  1097. if not CheckRestoredObject(Path+'.Context',Orig.Context,Rest.Context) then exit;
  1098. if Orig.Context<>nil then
  1099. begin
  1100. C:=Orig.Context.ClassType;
  1101. if C=TResolvedRefCtxConstructor then
  1102. CheckRestoredReference(Path+'.Context[TResolvedRefCtxConstructor].Typ',
  1103. TResolvedRefCtxConstructor(Orig.Context).Typ,
  1104. TResolvedRefCtxConstructor(Rest.Context).Typ);
  1105. end;
  1106. CheckRestoredScopeReference(Path+'.WithExprScope',Orig.WithExprScope,Rest.WithExprScope,Flags);
  1107. CheckRestoredReference(Path+'.Declaration',Orig.Declaration,Rest.Declaration);
  1108. CheckRestoredResolveData(Path,Orig,Rest,Flags);
  1109. end;
  1110. procedure TCustomTestPrecompile.CheckRestoredEvalValue(const Path: string;
  1111. Orig, Rest: TResEvalValue);
  1112. var
  1113. i: Integer;
  1114. begin
  1115. if not CheckRestoredObject(Path,Orig,Rest) then exit;
  1116. if Orig.Kind<>Rest.Kind then
  1117. Fail(Path+'.Kind');
  1118. if not CheckRestoredObject(Path+'.Element',Orig.Element,Rest.Element) then exit;
  1119. CheckRestoredReference(Path+'.IdentEl',Orig.IdentEl,Rest.IdentEl);
  1120. case Orig.Kind of
  1121. revkNone: Fail(Path+'.Kind=revkNone');
  1122. revkCustom: Fail(Path+'.Kind=revkNone');
  1123. revkNil: ;
  1124. revkBool: AssertEquals(Path+'.B',TResEvalBool(Orig).B,TResEvalBool(Rest).B);
  1125. revkInt: AssertEquals(Path+'.Int',TResEvalInt(Orig).Int,TResEvalInt(Rest).Int);
  1126. revkUInt:
  1127. if TResEvalUInt(Orig).UInt<>TResEvalUInt(Rest).UInt then
  1128. Fail(Path+'.UInt');
  1129. revkFloat: AssertEquals(Path+'.FloatValue',TResEvalFloat(Orig).FloatValue,TResEvalFloat(Rest).FloatValue);
  1130. revkString: AssertEquals(Path+'.S,Raw',TResEvalString(Orig).S,TResEvalString(Rest).S);
  1131. revkUnicodeString: AssertEquals(Path+'.S,UTF16',String(TResEvalUTF16(Orig).S),String(TResEvalUTF16(Rest).S));
  1132. revkEnum:
  1133. begin
  1134. AssertEquals(Path+'.Index',TResEvalEnum(Orig).Index,TResEvalEnum(Rest).Index);
  1135. CheckRestoredReference(Path+'.ElType',TResEvalEnum(Orig).ElType,TResEvalEnum(Rest).ElType);
  1136. end;
  1137. revkRangeInt:
  1138. begin
  1139. if TResEvalRangeInt(Orig).ElKind<>TResEvalRangeInt(Rest).ElKind then
  1140. Fail(Path+'.Int/ElKind');
  1141. CheckRestoredReference(Path+'.Int/ElType',TResEvalRangeInt(Orig).ElType,TResEvalRangeInt(Rest).ElType);
  1142. AssertEquals(Path+'.Int/RangeStart',TResEvalRangeInt(Orig).RangeStart,TResEvalRangeInt(Rest).RangeStart);
  1143. AssertEquals(Path+'.Int/RangeEnd',TResEvalRangeInt(Orig).RangeEnd,TResEvalRangeInt(Rest).RangeEnd);
  1144. end;
  1145. revkRangeUInt:
  1146. begin
  1147. if TResEvalRangeUInt(Orig).RangeStart<>TResEvalRangeUInt(Rest).RangeStart then
  1148. Fail(Path+'.UInt/RangeStart');
  1149. if TResEvalRangeUInt(Orig).RangeEnd<>TResEvalRangeUInt(Rest).RangeEnd then
  1150. Fail(Path+'.UInt/RangeEnd');
  1151. end;
  1152. revkSetOfInt:
  1153. begin
  1154. if TResEvalSet(Orig).ElKind<>TResEvalSet(Rest).ElKind then
  1155. Fail(Path+'.SetInt/ElKind');
  1156. CheckRestoredReference(Path+'.SetInt/ElType',TResEvalSet(Orig).ElType,TResEvalSet(Rest).ElType);
  1157. AssertEquals(Path+'.SetInt/RangeStart',TResEvalSet(Orig).RangeStart,TResEvalSet(Rest).RangeStart);
  1158. AssertEquals(Path+'.SetInt/RangeEnd',TResEvalSet(Orig).RangeEnd,TResEvalSet(Rest).RangeEnd);
  1159. AssertEquals(Path+'.SetInt/length(Items)',length(TResEvalSet(Orig).Ranges),length(TResEvalSet(Rest).Ranges));
  1160. for i:=0 to length(TResEvalSet(Orig).Ranges)-1 do
  1161. begin
  1162. AssertEquals(Path+'.SetInt/Items['+IntToStr(i)+'].RangeStart',
  1163. TResEvalSet(Orig).Ranges[i].RangeStart,TResEvalSet(Rest).Ranges[i].RangeStart);
  1164. AssertEquals(Path+'.SetInt/Items['+IntToStr(i)+'].RangeEnd',
  1165. TResEvalSet(Orig).Ranges[i].RangeEnd,TResEvalSet(Rest).Ranges[i].RangeEnd);
  1166. end;
  1167. end;
  1168. end;
  1169. end;
  1170. procedure TCustomTestPrecompile.CheckRestoredCustomData(const Path: string;
  1171. RestoredEl: TPasElement; Orig, Rest: TObject; Flags: TPCCheckFlags);
  1172. var
  1173. C: TClass;
  1174. begin
  1175. if PCCGeneric in Flags then
  1176. begin
  1177. if (Rest=nil) and (Orig<>nil) then
  1178. begin
  1179. C:=Orig.ClassType;
  1180. if (C=TResolvedReference)
  1181. or (C=TPasWithScope)
  1182. or (C=TPas2JSWithExprScope)
  1183. or (C=TPasForLoopScope)
  1184. or (C=TPasExceptOnScope)
  1185. or C.InheritsFrom(TResEvalValue) then
  1186. exit
  1187. else
  1188. Fail(Path+': Generic Orig='+GetObjName(Orig)+' Rest=nil');
  1189. end;
  1190. end;
  1191. if not CheckRestoredObject(Path,Orig,Rest) then exit;
  1192. C:=Orig.ClassType;
  1193. if C=TResolvedReference then
  1194. CheckRestoredResolvedReference(Path+'[TResolvedReference]',TResolvedReference(Orig),TResolvedReference(Rest),Flags)
  1195. else if C=TPas2JSModuleScope then
  1196. CheckRestoredModuleScope(Path+'[TPas2JSModuleScope]',TPas2JSModuleScope(Orig),TPas2JSModuleScope(Rest),Flags)
  1197. else if C=TPas2JSSectionScope then
  1198. CheckRestoredSectionScope(Path+'[TPas2JSSectionScope]',TPas2JSSectionScope(Orig),TPas2JSSectionScope(Rest),Flags)
  1199. else if C=TPas2JSInitialFinalizationScope then
  1200. CheckRestoredInitialFinalizationScope(Path+'[TPas2JSInitialFinalizationScope]',TPas2JSInitialFinalizationScope(Orig),TPas2JSInitialFinalizationScope(Rest),Flags)
  1201. else if C=TPasEnumTypeScope then
  1202. CheckRestoredEnumTypeScope(Path+'[TPasEnumTypeScope]',TPasEnumTypeScope(Orig),TPasEnumTypeScope(Rest),Flags)
  1203. else if C=TPas2jsRecordScope then
  1204. CheckRestoredRecordScope(Path+'[TPas2jsRecordScope]',TPas2jsRecordScope(Orig),TPas2jsRecordScope(Rest),Flags)
  1205. else if C=TPas2JSClassScope then
  1206. CheckRestoredClassScope(Path+'[TPas2JSClassScope]',TPas2JSClassScope(Orig),TPas2JSClassScope(Rest),Flags)
  1207. else if C=TPas2JSProcedureScope then
  1208. CheckRestoredProcScope(Path+'[TPas2JSProcedureScope]',TPas2JSProcedureScope(Orig),TPas2JSProcedureScope(Rest),Flags)
  1209. else if C=TPas2JSArrayScope then
  1210. CheckRestoredArrayScope(Path+'[TPas2JSArrayScope]',TPas2JSArrayScope(Orig),TPas2JSArrayScope(Rest),Flags)
  1211. else if C=TPas2JSProcTypeScope then
  1212. CheckRestoredProcTypeScope(Path+'[TPas2JSProcTypeScope]',TPas2JSProcTypeScope(Orig),TPas2JSProcTypeScope(Rest),Flags)
  1213. else if C=TPasPropertyScope then
  1214. CheckRestoredPropertyScope(Path+'[TPasPropertyScope]',TPasPropertyScope(Orig),TPasPropertyScope(Rest),Flags)
  1215. else if C=TPasGenericParamsScope then
  1216. CheckRestoredGenericParamScope(Path+'[TPasGenericParamScope]',TPasGenericParamsScope(Orig),TPasGenericParamsScope(Rest),Flags)
  1217. else if C=TPasSpecializeTypeData then
  1218. CheckRestoredSpecializeTypeData(Path+'[TPasSpecializeTypeData]',TPasSpecializeTypeData(Orig),TPasSpecializeTypeData(Rest),Flags)
  1219. else if C.InheritsFrom(TResEvalValue) then
  1220. CheckRestoredEvalValue(Path+'['+Orig.ClassName+']',TResEvalValue(Orig),TResEvalValue(Rest))
  1221. else
  1222. Fail(Path+': unknown CustomData "'+GetObjName(Orig)+'" El='+GetObjName(RestoredEl));
  1223. end;
  1224. procedure TCustomTestPrecompile.CheckRestoredReference(const Path: string;
  1225. Orig, Rest: TPasElement);
  1226. begin
  1227. if not CheckRestoredObject(Path,Orig,Rest) then exit;
  1228. AssertEquals(Path+'.Name',Orig.Name,Rest.Name);
  1229. if Orig is TPasUnresolvedSymbolRef then
  1230. exit; // compiler types and procs are the same in every unit -> skip checking unit
  1231. CheckRestoredReference(Path+'.Parent',Orig.Parent,Rest.Parent);
  1232. end;
  1233. procedure TCustomTestPrecompile.CheckRestoredElOrRef(const Path: string; Orig,
  1234. OrigProp, Rest, RestProp: TPasElement; Flags: TPCCheckFlags);
  1235. begin
  1236. if not CheckRestoredObject(Path,OrigProp,RestProp) then exit;
  1237. if Orig<>OrigProp.Parent then
  1238. begin
  1239. if Rest=RestProp.Parent then
  1240. Fail(Path+' Orig "'+GetObjName(OrigProp)+'" is reference Orig.Parent='+GetObjName(Orig)+', Rest "'+GetObjName(RestProp)+'" is insitu');
  1241. CheckRestoredReference(Path,OrigProp,RestProp);
  1242. end
  1243. else
  1244. CheckRestoredElement(Path,OrigProp,RestProp,Flags);
  1245. end;
  1246. procedure TCustomTestPrecompile.CheckRestoredAnalyzerElement(
  1247. const Path: string; Orig, Rest: TPasElement);
  1248. var
  1249. OrigUsed, RestUsed: TPAElement;
  1250. begin
  1251. //writeln('TCustomTestPrecompile.CheckRestoredAnalyzerElement ',GetObjName(RestAnalyzer));
  1252. if RestAnalyzer=nil then exit;
  1253. if Orig.ClassType=TPasArgument then exit;
  1254. OrigUsed:=Analyzer.FindUsedElement(Orig);
  1255. //writeln('TCustomTestPrecompile.CheckRestoredAnalyzerElement ',GetObjName(Orig),'=',OrigUsed<>nil,' ',GetObjName(Rest),'=',RestAnalyzer.FindUsedElement(Rest)<>nil);
  1256. if OrigUsed<>nil then
  1257. begin
  1258. RestUsed:=RestAnalyzer.FindUsedElement(Rest);
  1259. if RestUsed=nil then
  1260. Fail(Path+': used in OrigAnalyzer, but not used in RestAnalyzer');
  1261. if OrigUsed.Access<>RestUsed.Access then
  1262. begin
  1263. if (OrigUsed.Access in [paiaReadWrite,paiaWriteRead])
  1264. and (RestUsed.Access in [paiaReadWrite,paiaWriteRead])
  1265. and not (Orig.Parent is TProcedureBody) then
  1266. // readwrite or writeread is irrelevant for globals
  1267. else
  1268. AssertEquals(Path+'->Analyzer.Access',dbgs(OrigUsed.Access),dbgs(RestUsed.Access));
  1269. end;
  1270. end
  1271. else if RestAnalyzer.IsUsed(Rest) then
  1272. begin
  1273. Fail(Path+': not used in OrigAnalyzer, but used in RestAnalyzer');
  1274. end;
  1275. end;
  1276. procedure TCustomTestPrecompile.CheckRestoredElement(const Path: string; Orig,
  1277. Rest: TPasElement; Flags: TPCCheckFlags);
  1278. var
  1279. C: TClass;
  1280. AModule: TPasModule;
  1281. Pair: TPCCheckedElementPair;
  1282. begin
  1283. //writeln('TCustomTestPrecompile.CheckRestoredElement START Orig=',GetObjName(Orig),' Rest=',GetObjName(Rest));
  1284. if not CheckRestoredObject(Path,Orig,Rest) then exit;
  1285. //writeln('TCustomTestPrecompile.CheckRestoredElement CheckRestoredObject Orig=',GetObjName(Orig),' Rest=',GetObjName(Rest));
  1286. Pair:=TPCCheckedElementPair(FCheckedElements.FindKey(Orig));
  1287. if Pair<>nil then
  1288. begin
  1289. if Pair.Rest<>Rest then
  1290. Fail(Path+': Orig='+GetObjPath(Orig)+' Rest='+GetObjPath(Rest));
  1291. exit;
  1292. end
  1293. else
  1294. begin
  1295. Pair:=TPCCheckedElementPair.Create;
  1296. Pair.Orig:=Orig;
  1297. Pair.Rest:=Rest;
  1298. FCheckedElements.Add(Pair,false);
  1299. end;
  1300. AModule:=Orig.GetModule;
  1301. if AModule<>Module then
  1302. begin
  1303. if (Orig is TPasUnresolvedSymbolRef) then
  1304. begin
  1305. // built-in identifier
  1306. if not SameText(Orig.Name,Rest.Name) then
  1307. AssertEquals(Path+'.Name',Orig.Name,Rest.Name);
  1308. if not CheckRestoredObject(Path+'.CustomData',Orig.CustomData,Rest.CustomData) then exit;
  1309. exit;
  1310. end;
  1311. Fail(Path+' wrong module: Orig='+GetObjName(AModule)+' '+GetObjName(Module));
  1312. end;
  1313. AssertEquals(Path+'.Name',Orig.Name,Rest.Name);
  1314. AssertEquals(Path+'.SourceFilename',Orig.SourceFilename,Rest.SourceFilename);
  1315. AssertEquals(Path+'.SourceLinenumber',Orig.SourceLinenumber,Rest.SourceLinenumber);
  1316. //AssertEquals(Path+'.SourceEndLinenumber',Orig.SourceEndLinenumber,Rest.SourceEndLinenumber);
  1317. if Orig.Visibility<>Rest.Visibility then
  1318. Fail(Path+'.Visibility '+PCUMemberVisibilityNames[Orig.Visibility]+' '+PCUMemberVisibilityNames[Rest.Visibility]);
  1319. if Orig.Hints<>Rest.Hints then
  1320. Fail(Path+'.Hints');
  1321. AssertEquals(Path+'.HintMessage',Orig.HintMessage,Rest.HintMessage);
  1322. //writeln('TCustomTestPrecompile.CheckRestoredElement Checking Parent... Orig=',GetObjName(Orig),' Rest=',GetObjName(Rest));
  1323. CheckRestoredReference(Path+'.Parent',Orig.Parent,Rest.Parent);
  1324. C:=Orig.ClassType;
  1325. //writeln('TCustomTestPrecompile.CheckRestoredElement Checking CustomData... Orig=',GetObjName(Orig),' Rest=',GetObjName(Rest));
  1326. if C=TPasGenericTemplateType then
  1327. begin
  1328. // TPasGenericParamsScope is only needed during parsing
  1329. if Orig.CustomData=nil then
  1330. else if not (Orig.CustomData is TPasGenericParamsScope) then
  1331. Fail(Path+'Orig.CustomData='+GetObjName(Orig.CustomData))
  1332. else if Rest.CustomData<>nil then
  1333. CheckRestoredCustomData(Path+'.CustomData',Rest,Orig.CustomData,Rest.CustomData,Flags);
  1334. end
  1335. else
  1336. CheckRestoredCustomData(Path+'.CustomData',Rest,Orig.CustomData,Rest.CustomData,Flags);
  1337. if C=TUnaryExpr then
  1338. CheckRestoredUnaryExpr(Path,TUnaryExpr(Orig),TUnaryExpr(Rest),Flags)
  1339. else if C=TBinaryExpr then
  1340. CheckRestoredBinaryExpr(Path,TBinaryExpr(Orig),TBinaryExpr(Rest),Flags)
  1341. else if C=TPrimitiveExpr then
  1342. CheckRestoredPrimitiveExpr(Path,TPrimitiveExpr(Orig),TPrimitiveExpr(Rest),Flags)
  1343. else if C=TBoolConstExpr then
  1344. CheckRestoredBoolConstExpr(Path,TBoolConstExpr(Orig),TBoolConstExpr(Rest),Flags)
  1345. else if (C=TNilExpr)
  1346. or (C=TInheritedExpr)
  1347. or (C=TSelfExpr) then
  1348. CheckRestoredPasExpr(Path,TPasExpr(Orig),TPasExpr(Rest),Flags)
  1349. else if C=TParamsExpr then
  1350. CheckRestoredParamsExpr(Path,TParamsExpr(Orig),TParamsExpr(Rest),Flags)
  1351. else if C=TProcedureExpr then
  1352. CheckRestoredProcedureExpr(Path,TProcedureExpr(Orig),TProcedureExpr(Rest),Flags)
  1353. else if C=TRecordValues then
  1354. CheckRestoredRecordValues(Path,TRecordValues(Orig),TRecordValues(Rest),Flags)
  1355. else if C=TArrayValues then
  1356. CheckRestoredArrayValues(Path,TArrayValues(Orig),TArrayValues(Rest),Flags)
  1357. // TPasDeclarations is a base class
  1358. // TPasUsesUnit is checked in usesclause
  1359. // TPasSection is a base class
  1360. else if C=TPasResString then
  1361. CheckRestoredResString(Path,TPasResString(Orig),TPasResString(Rest),Flags)
  1362. // TPasType is a base clas
  1363. else if (C=TPasAliasType)
  1364. or (C=TPasTypeAliasType)
  1365. or (C=TPasClassOfType) then
  1366. CheckRestoredAliasType(Path,TPasAliasType(Orig),TPasAliasType(Rest),Flags)
  1367. else if C=TPasPointerType then
  1368. CheckRestoredPointerType(Path,TPasPointerType(Orig),TPasPointerType(Rest),Flags)
  1369. else if C=TPasSpecializeType then
  1370. CheckRestoredSpecializedType(Path,TPasSpecializeType(Orig),TPasSpecializeType(Rest),Flags)
  1371. else if C=TInlineSpecializeExpr then
  1372. CheckRestoredInlineSpecializedExpr(Path,TInlineSpecializeExpr(Orig),TInlineSpecializeExpr(Rest),Flags)
  1373. else if C=TPasGenericTemplateType then
  1374. CheckRestoredGenericTemplateType(Path,TPasGenericTemplateType(Orig),TPasGenericTemplateType(Rest),Flags)
  1375. else if C=TPasRangeType then
  1376. CheckRestoredRangeType(Path,TPasRangeType(Orig),TPasRangeType(Rest),Flags)
  1377. else if C=TPasArrayType then
  1378. CheckRestoredArrayType(Path,TPasArrayType(Orig),TPasArrayType(Rest),Flags)
  1379. else if C=TPasFileType then
  1380. CheckRestoredFileType(Path,TPasFileType(Orig),TPasFileType(Rest),Flags)
  1381. else if C=TPasEnumValue then
  1382. CheckRestoredEnumValue(Path,TPasEnumValue(Orig),TPasEnumValue(Rest),Flags)
  1383. else if C=TPasEnumType then
  1384. CheckRestoredEnumType(Path,TPasEnumType(Orig),TPasEnumType(Rest),Flags)
  1385. else if C=TPasSetType then
  1386. CheckRestoredSetType(Path,TPasSetType(Orig),TPasSetType(Rest),Flags)
  1387. else if C=TPasVariant then
  1388. CheckRestoredVariant(Path,TPasVariant(Orig),TPasVariant(Rest),Flags)
  1389. else if C=TPasRecordType then
  1390. CheckRestoredRecordType(Path,TPasRecordType(Orig),TPasRecordType(Rest),Flags)
  1391. else if C=TPasClassType then
  1392. CheckRestoredClassType(Path,TPasClassType(Orig),TPasClassType(Rest),Flags)
  1393. else if C=TPasArgument then
  1394. CheckRestoredArgument(Path,TPasArgument(Orig),TPasArgument(Rest),Flags)
  1395. else if C=TPasProcedureType then
  1396. CheckRestoredProcedureType(Path,TPasProcedureType(Orig),TPasProcedureType(Rest),Flags)
  1397. else if C=TPasResultElement then
  1398. CheckRestoredResultElement(Path,TPasResultElement(Orig),TPasResultElement(Rest),Flags)
  1399. else if C=TPasFunctionType then
  1400. CheckRestoredFunctionType(Path,TPasFunctionType(Orig),TPasFunctionType(Rest),Flags)
  1401. else if C=TPasStringType then
  1402. CheckRestoredStringType(Path,TPasStringType(Orig),TPasStringType(Rest),Flags)
  1403. else if C=TPasVariable then
  1404. CheckRestoredVariable(Path,TPasVariable(Orig),TPasVariable(Rest),Flags)
  1405. else if C=TPasExportSymbol then
  1406. CheckRestoredExportSymbol(Path,TPasExportSymbol(Orig),TPasExportSymbol(Rest),Flags)
  1407. else if C=TPasConst then
  1408. CheckRestoredConst(Path,TPasConst(Orig),TPasConst(Rest),Flags)
  1409. else if C=TPasProperty then
  1410. CheckRestoredProperty(Path,TPasProperty(Orig),TPasProperty(Rest),Flags)
  1411. else if C=TPasMethodResolution then
  1412. CheckRestoredMethodResolution(Path,TPasMethodResolution(Orig),TPasMethodResolution(Rest),Flags)
  1413. else if (C=TPasProcedure)
  1414. or (C=TPasFunction)
  1415. or (C=TPasConstructor)
  1416. or (C=TPasClassConstructor)
  1417. or (C=TPasDestructor)
  1418. or (C=TPasClassDestructor)
  1419. or (C=TPasClassProcedure)
  1420. or (C=TPasClassFunction)
  1421. then
  1422. CheckRestoredProcedure(Path,TPasProcedure(Orig),TPasProcedure(Rest),Flags)
  1423. else if (C=TPasOperator)
  1424. or (C=TPasClassOperator) then
  1425. CheckRestoredOperator(Path,TPasOperator(Orig),TPasOperator(Rest),Flags)
  1426. else if (C=TPasImplCommand) then
  1427. CheckRestoredImplCommand(Path,TPasImplCommand(Orig),TPasImplCommand(Rest),Flags)
  1428. else if (C=TPasImplBeginBlock) then
  1429. CheckRestoredImplBeginBlock(Path,TPasImplBeginBlock(Orig),TPasImplBeginBlock(Rest),Flags)
  1430. else if (C=TPasImplAsmStatement) then
  1431. CheckRestoredImplAsmStatement(Path,TPasImplAsmStatement(Orig),TPasImplAsmStatement(Rest),Flags)
  1432. else if (C=TPasImplRepeatUntil) then
  1433. CheckRestoredImplRepeatUntil(Path,TPasImplRepeatUntil(Orig),TPasImplRepeatUntil(Rest),Flags)
  1434. else if (C=TPasImplIfElse) then
  1435. CheckRestoredImplIfElse(Path,TPasImplIfElse(Orig),TPasImplIfElse(Rest),Flags)
  1436. else if (C=TPasImplWhileDo) then
  1437. CheckRestoredImplWhileDo(Path,TPasImplWhileDo(Orig),TPasImplWhileDo(Rest),Flags)
  1438. else if (C=TPasImplWithDo) then
  1439. CheckRestoredImplWithDo(Path,TPasImplWithDo(Orig),TPasImplWithDo(Rest),Flags)
  1440. else if (C=TPasImplCaseOf) then
  1441. CheckRestoredImplCaseOf(Path,TPasImplCaseOf(Orig),TPasImplCaseOf(Rest),Flags)
  1442. else if (C=TPasImplCaseStatement) then
  1443. CheckRestoredImplCaseStatement(Path,TPasImplCaseStatement(Orig),TPasImplCaseStatement(Rest),Flags)
  1444. else if (C=TPasImplCaseElse) then
  1445. CheckRestoredImplCaseElse(Path,TPasImplCaseElse(Orig),TPasImplCaseElse(Rest),Flags)
  1446. else if (C=TPasImplForLoop) then
  1447. CheckRestoredImplForLoop(Path,TPasImplForLoop(Orig),TPasImplForLoop(Rest),Flags)
  1448. else if (C=TPasImplAssign) then
  1449. CheckRestoredImplAssign(Path,TPasImplAssign(Orig),TPasImplAssign(Rest),Flags)
  1450. else if (C=TPasImplSimple) then
  1451. CheckRestoredImplSimple(Path,TPasImplSimple(Orig),TPasImplSimple(Rest),Flags)
  1452. else if (C=TPasImplTry) then
  1453. CheckRestoredImplTry(Path,TPasImplTry(Orig),TPasImplTry(Rest),Flags)
  1454. else if (C=TPasImplTryFinally)
  1455. or (C=TPasImplTryExcept)
  1456. or (C=TPasImplTryExceptElse) then
  1457. CheckRestoredImplTryHandler(Path,TPasImplTryHandler(Orig),TPasImplTryHandler(Rest),Flags)
  1458. else if (C=TPasImplExceptOn) then
  1459. CheckRestoredImplExceptOn(Path,TPasImplExceptOn(Orig),TPasImplExceptOn(Rest),Flags)
  1460. else if (C=TPasImplRaise) then
  1461. CheckRestoredImplRaise(Path,TPasImplRaise(Orig),TPasImplRaise(Rest),Flags)
  1462. else if (C=TPasModule)
  1463. or (C=TPasProgram)
  1464. or (C=TPasLibrary) then
  1465. CheckRestoredModule(Path,TPasModule(Orig),TPasModule(Rest),Flags)
  1466. else if C.InheritsFrom(TPasSection) then
  1467. CheckRestoredSection(Path,TPasSection(Orig),TPasSection(Rest),Flags)
  1468. else if C=TPasAttributes then
  1469. CheckRestoredAttributes(Path,TPasAttributes(Orig),TPasAttributes(Rest),Flags)
  1470. else
  1471. Fail(Path+': unknown class '+C.ClassName);
  1472. CheckRestoredAnalyzerElement(Path,Orig,Rest);
  1473. end;
  1474. procedure TCustomTestPrecompile.CheckRestoredElementList(const Path: string;
  1475. Orig, Rest: TFPList; Flags: TPCCheckFlags);
  1476. var
  1477. OrigItem, RestItem: TObject;
  1478. i: Integer;
  1479. SubPath: String;
  1480. begin
  1481. if not CheckRestoredObject(Path,Orig,Rest) then exit;
  1482. AssertEquals(Path+'.Count',Orig.Count,Rest.Count);
  1483. for i:=0 to Orig.Count-1 do
  1484. begin
  1485. SubPath:=Path+'['+IntToStr(i)+']';
  1486. OrigItem:=TObject(Orig[i]);
  1487. if not (OrigItem is TPasElement) then
  1488. Fail(SubPath+' Orig='+GetObjName(OrigItem));
  1489. RestItem:=TObject(Rest[i]);
  1490. if not (RestItem is TPasElement) then
  1491. Fail(SubPath+' Rest='+GetObjName(RestItem));
  1492. //writeln('TCustomTestPrecompile.CheckRestoredElementList ',GetObjName(OrigItem),' ',GetObjName(RestItem));
  1493. SubPath:=Path+'['+IntToStr(i)+']"'+TPasElement(OrigItem).Name+'"';
  1494. CheckRestoredElement(SubPath,TPasElement(OrigItem),TPasElement(RestItem),Flags);
  1495. end;
  1496. end;
  1497. procedure TCustomTestPrecompile.CheckRestoredElementArray(const Path: string;
  1498. Orig, Rest: TPasElementArray; Flags: TPCCheckFlags);
  1499. var
  1500. OrigItem, RestItem: TPasElement;
  1501. i: Integer;
  1502. SubPath: String;
  1503. begin
  1504. AssertEquals(Path+'.length',length(Orig),length(Rest));
  1505. for i:=0 to length(Orig)-1 do
  1506. begin
  1507. SubPath:=Path+'['+IntToStr(i)+']';
  1508. OrigItem:=Orig[i];
  1509. if not (OrigItem is TPasElement) then
  1510. Fail(SubPath+' Orig='+GetObjName(OrigItem));
  1511. RestItem:=Rest[i];
  1512. if not (RestItem is TPasElement) then
  1513. Fail(SubPath+' Rest='+GetObjName(RestItem));
  1514. //writeln('TCustomTestPrecompile.CheckRestoredElementList ',GetObjName(OrigItem),' ',GetObjName(RestItem));
  1515. SubPath:=Path+'['+IntToStr(i)+']"'+TPasElement(OrigItem).Name+'"';
  1516. CheckRestoredElement(SubPath,TPasElement(OrigItem),TPasElement(RestItem),Flags);
  1517. end;
  1518. end;
  1519. procedure TCustomTestPrecompile.CheckRestoredElRefList(const Path: string;
  1520. OrigParent: TPasElement; Orig: TFPList; RestParent: TPasElement;
  1521. Rest: TFPList; AllowInSitu: boolean; Flags: TPCCheckFlags);
  1522. var
  1523. OrigItem, RestItem: TObject;
  1524. i: Integer;
  1525. SubPath: String;
  1526. begin
  1527. if not CheckRestoredObject(Path,Orig,Rest) then exit;
  1528. AssertEquals(Path+'.Count',Orig.Count,Rest.Count);
  1529. for i:=0 to Orig.Count-1 do
  1530. begin
  1531. SubPath:=Path+'['+IntToStr(i)+']';
  1532. OrigItem:=TObject(Orig[i]);
  1533. if not (OrigItem is TPasElement) then
  1534. Fail(SubPath+' Orig='+GetObjName(OrigItem));
  1535. RestItem:=TObject(Rest[i]);
  1536. if not (RestItem is TPasElement) then
  1537. Fail(SubPath+' Rest='+GetObjName(RestItem));
  1538. if AllowInSitu then
  1539. CheckRestoredElOrRef(SubPath,OrigParent,TPasElement(OrigItem),RestParent,TPasElement(RestItem),Flags)
  1540. else
  1541. CheckRestoredReference(SubPath,TPasElement(OrigItem),TPasElement(RestItem));
  1542. end;
  1543. end;
  1544. procedure TCustomTestPrecompile.CheckRestoredPasExpr(const Path: string; Orig,
  1545. Rest: TPasExpr; Flags: TPCCheckFlags);
  1546. begin
  1547. if Orig.Kind<>Rest.Kind then
  1548. Fail(Path+'.Kind');
  1549. if Orig.OpCode<>Rest.OpCode then
  1550. Fail(Path+'.OpCode');
  1551. CheckRestoredElement(Path+'.Format1',Orig.format1,Rest.format1,Flags);
  1552. CheckRestoredElement(Path+'.Format2',Orig.format2,Rest.format2,Flags);
  1553. end;
  1554. procedure TCustomTestPrecompile.CheckRestoredUnaryExpr(const Path: string;
  1555. Orig, Rest: TUnaryExpr; Flags: TPCCheckFlags);
  1556. begin
  1557. CheckRestoredElement(Path+'.Operand',Orig.Operand,Rest.Operand,Flags);
  1558. CheckRestoredPasExpr(Path,Orig,Rest,Flags);
  1559. end;
  1560. procedure TCustomTestPrecompile.CheckRestoredBinaryExpr(const Path: string;
  1561. Orig, Rest: TBinaryExpr; Flags: TPCCheckFlags);
  1562. begin
  1563. CheckRestoredElement(Path+'.left',Orig.left,Rest.left,Flags);
  1564. CheckRestoredElement(Path+'.right',Orig.right,Rest.right,Flags);
  1565. CheckRestoredPasExpr(Path,Orig,Rest,Flags);
  1566. end;
  1567. procedure TCustomTestPrecompile.CheckRestoredPrimitiveExpr(const Path: string;
  1568. Orig, Rest: TPrimitiveExpr; Flags: TPCCheckFlags);
  1569. begin
  1570. AssertEquals(Path+'.Value',Orig.Value,Rest.Value);
  1571. CheckRestoredPasExpr(Path,Orig,Rest,Flags);
  1572. end;
  1573. procedure TCustomTestPrecompile.CheckRestoredBoolConstExpr(const Path: string;
  1574. Orig, Rest: TBoolConstExpr; Flags: TPCCheckFlags);
  1575. begin
  1576. AssertEquals(Path+'.Value',Orig.Value,Rest.Value);
  1577. CheckRestoredPasExpr(Path,Orig,Rest,Flags);
  1578. end;
  1579. procedure TCustomTestPrecompile.CheckRestoredParamsExpr(const Path: string;
  1580. Orig, Rest: TParamsExpr; Flags: TPCCheckFlags);
  1581. begin
  1582. CheckRestoredElement(Path+'.Value',Orig.Value,Rest.Value,Flags);
  1583. CheckRestoredPasExprArray(Path+'.Params',Orig.Params,Rest.Params,Flags);
  1584. CheckRestoredPasExpr(Path,Orig,Rest,Flags);
  1585. end;
  1586. procedure TCustomTestPrecompile.CheckRestoredProcedureExpr(const Path: string;
  1587. Orig, Rest: TProcedureExpr; Flags: TPCCheckFlags);
  1588. begin
  1589. CheckRestoredProcedure(Path+'$Ano',Orig.Proc,Rest.Proc,Flags);
  1590. CheckRestoredPasExpr(Path,Orig,Rest,Flags);
  1591. end;
  1592. procedure TCustomTestPrecompile.CheckRestoredRecordValues(const Path: string;
  1593. Orig, Rest: TRecordValues; Flags: TPCCheckFlags);
  1594. var
  1595. i: Integer;
  1596. begin
  1597. AssertEquals(Path+'.Fields.length',length(Orig.Fields),length(Rest.Fields));
  1598. for i:=0 to length(Orig.Fields)-1 do
  1599. begin
  1600. AssertEquals(Path+'.Field['+IntToStr(i)+'].Name',Orig.Fields[i].Name,Rest.Fields[i].Name);
  1601. CheckRestoredElement(Path+'.Field['+IntToStr(i)+'].ValueExp',Orig.Fields[i].ValueExp,Rest.Fields[i].ValueExp,Flags);
  1602. end;
  1603. CheckRestoredPasExpr(Path,Orig,Rest,Flags);
  1604. end;
  1605. procedure TCustomTestPrecompile.CheckRestoredPasExprArray(const Path: string;
  1606. Orig, Rest: TPasExprArray; Flags: TPCCheckFlags);
  1607. var
  1608. i: Integer;
  1609. begin
  1610. AssertEquals(Path+'.length',length(Orig),length(Rest));
  1611. for i:=0 to length(Orig)-1 do
  1612. CheckRestoredElement(Path+'['+IntToStr(i)+']',Orig[i],Rest[i],Flags);
  1613. end;
  1614. procedure TCustomTestPrecompile.CheckRestoredArrayValues(const Path: string;
  1615. Orig, Rest: TArrayValues; Flags: TPCCheckFlags);
  1616. begin
  1617. CheckRestoredPasExprArray(Path+'.Values',Orig.Values,Rest.Values,Flags);
  1618. CheckRestoredPasExpr(Path,Orig,Rest,Flags);
  1619. end;
  1620. procedure TCustomTestPrecompile.CheckRestoredResString(const Path: string;
  1621. Orig, Rest: TPasResString; Flags: TPCCheckFlags);
  1622. begin
  1623. CheckRestoredElement(Path+'.Expr',Orig.Expr,Rest.Expr,Flags);
  1624. end;
  1625. procedure TCustomTestPrecompile.CheckRestoredAliasType(const Path: string;
  1626. Orig, Rest: TPasAliasType; Flags: TPCCheckFlags);
  1627. begin
  1628. CheckRestoredElOrRef(Path+'.DestType',Orig,Orig.DestType,Rest,Rest.DestType,Flags);
  1629. CheckRestoredElement(Path+'.Expr',Orig.Expr,Rest.Expr,Flags);
  1630. end;
  1631. procedure TCustomTestPrecompile.CheckRestoredPointerType(const Path: string;
  1632. Orig, Rest: TPasPointerType; Flags: TPCCheckFlags);
  1633. begin
  1634. CheckRestoredElOrRef(Path+'.DestType',Orig,Orig.DestType,Rest,Rest.DestType,Flags);
  1635. end;
  1636. procedure TCustomTestPrecompile.CheckRestoredSpecializedType(
  1637. const Path: string; Orig, Rest: TPasSpecializeType; Flags: TPCCheckFlags);
  1638. begin
  1639. CheckRestoredElementList(Path+'.Params',Orig.Params,Rest.Params,Flags);
  1640. CheckRestoredElOrRef(Path+'.DestType',Orig,Orig.DestType,Rest,Rest.DestType,Flags);
  1641. end;
  1642. procedure TCustomTestPrecompile.CheckRestoredInlineSpecializedExpr(
  1643. const Path: string; Orig, Rest: TInlineSpecializeExpr; Flags: TPCCheckFlags);
  1644. begin
  1645. CheckRestoredElement(Path+'.Name',Orig.NameExpr,Rest.NameExpr,Flags);
  1646. CheckRestoredElementList(Path+'.Params',Orig.Params,Rest.Params,Flags);
  1647. end;
  1648. procedure TCustomTestPrecompile.CheckRestoredGenericTemplateType(
  1649. const Path: string; Orig, Rest: TPasGenericTemplateType; Flags: TPCCheckFlags
  1650. );
  1651. begin
  1652. CheckRestoredElementArray(Path+'.Constraints',Orig.Constraints,Rest.Constraints,Flags);
  1653. end;
  1654. procedure TCustomTestPrecompile.CheckRestoredRangeType(const Path: string;
  1655. Orig, Rest: TPasRangeType; Flags: TPCCheckFlags);
  1656. begin
  1657. CheckRestoredElement(Path+'.RangeExpr',Orig.RangeExpr,Rest.RangeExpr,Flags);
  1658. end;
  1659. procedure TCustomTestPrecompile.CheckRestoredArrayType(const Path: string;
  1660. Orig, Rest: TPasArrayType; Flags: TPCCheckFlags);
  1661. begin
  1662. CheckRestoredPasExprArray(Path+'.Ranges',Orig.Ranges,Rest.Ranges,Flags);
  1663. CheckRestoredElementList(Path+'.GenericTemplateTypes',Orig.GenericTemplateTypes,Rest.GenericTemplateTypes,Flags);
  1664. if Orig.PackMode<>Rest.PackMode then
  1665. Fail(Path+'.PackMode Orig='+PCUPackModeNames[Orig.PackMode]+' Rest='+PCUPackModeNames[Rest.PackMode]);
  1666. CheckRestoredElOrRef(Path+'.ElType',Orig,Orig.ElType,Rest,Rest.ElType,Flags);
  1667. end;
  1668. procedure TCustomTestPrecompile.CheckRestoredFileType(const Path: string; Orig,
  1669. Rest: TPasFileType; Flags: TPCCheckFlags);
  1670. begin
  1671. CheckRestoredElOrRef(Path+'.ElType',Orig,Orig.ElType,Rest,Rest.ElType,Flags);
  1672. end;
  1673. procedure TCustomTestPrecompile.CheckRestoredEnumValue(const Path: string;
  1674. Orig, Rest: TPasEnumValue; Flags: TPCCheckFlags);
  1675. begin
  1676. CheckRestoredElement(Path+'.Value',Orig.Value,Rest.Value,Flags);
  1677. end;
  1678. procedure TCustomTestPrecompile.CheckRestoredEnumType(const Path: string; Orig,
  1679. Rest: TPasEnumType; Flags: TPCCheckFlags);
  1680. begin
  1681. CheckRestoredElementList(Path+'.Values',Orig.Values,Rest.Values,Flags);
  1682. end;
  1683. procedure TCustomTestPrecompile.CheckRestoredSetType(const Path: string; Orig,
  1684. Rest: TPasSetType; Flags: TPCCheckFlags);
  1685. begin
  1686. CheckRestoredElOrRef(Path+'.EnumType',Orig,Orig.EnumType,Rest,Rest.EnumType,Flags);
  1687. AssertEquals(Path+'.IsPacked',Orig.IsPacked,Rest.IsPacked);
  1688. end;
  1689. procedure TCustomTestPrecompile.CheckRestoredVariant(const Path: string; Orig,
  1690. Rest: TPasVariant; Flags: TPCCheckFlags);
  1691. begin
  1692. CheckRestoredElementList(Path+'.Values',Orig.Values,Rest.Values,Flags);
  1693. CheckRestoredElement(Path+'.Members',Orig.Members,Rest.Members,Flags);
  1694. end;
  1695. procedure TCustomTestPrecompile.CheckRestoredRecordType(const Path: string;
  1696. Orig, Rest: TPasRecordType; Flags: TPCCheckFlags);
  1697. begin
  1698. CheckRestoredElementList(Path+'.GenericTemplateTypes',Orig.GenericTemplateTypes,Rest.GenericTemplateTypes,Flags);
  1699. if Orig.PackMode<>Rest.PackMode then
  1700. Fail(Path+'.PackMode Orig='+PCUPackModeNames[Orig.PackMode]+' Rest='+PCUPackModeNames[Rest.PackMode]);
  1701. CheckRestoredElementList(Path+'.Members',Orig.Members,Rest.Members,Flags);
  1702. CheckRestoredElOrRef(Path+'.VariantEl',Orig,Orig.VariantEl,Rest,Rest.VariantEl,Flags);
  1703. CheckRestoredElementList(Path+'.Variants',Orig.Variants,Rest.Variants,Flags);
  1704. CheckRestoredElementList(Path+'.GenericTemplateTypes',Orig.GenericTemplateTypes,Rest.GenericTemplateTypes,Flags);
  1705. end;
  1706. procedure TCustomTestPrecompile.CheckRestoredClassType(const Path: string;
  1707. Orig, Rest: TPasClassType; Flags: TPCCheckFlags);
  1708. begin
  1709. CheckRestoredElementList(Path+'.GenericTemplateTypes',Orig.GenericTemplateTypes,Rest.GenericTemplateTypes,Flags);
  1710. if Orig.PackMode<>Rest.PackMode then
  1711. Fail(Path+'.PackMode Orig='+PCUPackModeNames[Orig.PackMode]+' Rest='+PCUPackModeNames[Rest.PackMode]);
  1712. if Orig.ObjKind<>Rest.ObjKind then
  1713. Fail(Path+'.ObjKind Orig='+PCUObjKindNames[Orig.ObjKind]+' Rest='+PCUObjKindNames[Rest.ObjKind]);
  1714. if Orig.InterfaceType<>Rest.InterfaceType then
  1715. Fail(Path+'.ObjKind Orig='+PCUClassInterfaceTypeNames[Orig.InterfaceType]+' Rest='+PCUClassInterfaceTypeNames[Rest.InterfaceType]);
  1716. CheckRestoredReference(Path+'.AncestorType',Orig.AncestorType,Rest.AncestorType);
  1717. CheckRestoredReference(Path+'.HelperForType',Orig.HelperForType,Rest.HelperForType);
  1718. AssertEquals(Path+'.IsForward',Orig.IsForward,Rest.IsForward);
  1719. AssertEquals(Path+'.IsExternal',Orig.IsExternal,Rest.IsExternal);
  1720. // irrelevant: IsShortDefinition
  1721. CheckRestoredElement(Path+'.GUIDExpr',Orig.GUIDExpr,Rest.GUIDExpr,Flags);
  1722. CheckRestoredElementList(Path+'.Members',Orig.Members,Rest.Members,Flags);
  1723. AssertEquals(Path+'.Modifiers',Orig.Modifiers.Text,Rest.Modifiers.Text);
  1724. CheckRestoredElRefList(Path+'.Interfaces',Orig,Orig.Interfaces,Rest,Rest.Interfaces,false,Flags);
  1725. CheckRestoredElementList(Path+'.GenericTemplateTypes',Orig.GenericTemplateTypes,Rest.GenericTemplateTypes,Flags);
  1726. AssertEquals(Path+'.ExternalNameSpace',Orig.ExternalNameSpace,Rest.ExternalNameSpace);
  1727. AssertEquals(Path+'.ExternalName',Orig.ExternalName,Rest.ExternalName);
  1728. end;
  1729. procedure TCustomTestPrecompile.CheckRestoredArgument(const Path: string; Orig,
  1730. Rest: TPasArgument; Flags: TPCCheckFlags);
  1731. begin
  1732. if Orig.Access<>Rest.Access then
  1733. Fail(Path+'.Access Orig='+PCUArgumentAccessNames[Orig.Access]+' Rest='+PCUArgumentAccessNames[Rest.Access]);
  1734. CheckRestoredElOrRef(Path+'.ArgType',Orig,Orig.ArgType,Rest,Rest.ArgType,Flags);
  1735. CheckRestoredElement(Path+'.ValueExpr',Orig.ValueExpr,Rest.ValueExpr,Flags);
  1736. end;
  1737. procedure TCustomTestPrecompile.CheckRestoredProcedureType(const Path: string;
  1738. Orig, Rest: TPasProcedureType; Flags: TPCCheckFlags);
  1739. begin
  1740. CheckRestoredElementList(Path+'.GenericTemplateTypes',Orig.GenericTemplateTypes,Rest.GenericTemplateTypes,Flags);
  1741. CheckRestoredElementList(Path+'.Args',Orig.Args,Rest.Args,Flags);
  1742. if Orig.CallingConvention<>Rest.CallingConvention then
  1743. Fail(Path+'.CallingConvention Orig='+PCUCallingConventionNames[Orig.CallingConvention]+' Rest='+PCUCallingConventionNames[Rest.CallingConvention]);
  1744. if Orig.Modifiers<>Rest.Modifiers then
  1745. Fail(Path+'.Modifiers');
  1746. end;
  1747. procedure TCustomTestPrecompile.CheckRestoredResultElement(const Path: string;
  1748. Orig, Rest: TPasResultElement; Flags: TPCCheckFlags);
  1749. begin
  1750. CheckRestoredElOrRef(Path+'.ResultType',Orig,Orig.ResultType,Rest,Rest.ResultType,Flags);
  1751. end;
  1752. procedure TCustomTestPrecompile.CheckRestoredFunctionType(const Path: string;
  1753. Orig, Rest: TPasFunctionType; Flags: TPCCheckFlags);
  1754. begin
  1755. CheckRestoredElement(Path+'.ResultEl',Orig.ResultEl,Rest.ResultEl,Flags);
  1756. CheckRestoredProcedureType(Path,Orig,Rest,Flags);
  1757. end;
  1758. procedure TCustomTestPrecompile.CheckRestoredStringType(const Path: string;
  1759. Orig, Rest: TPasStringType; Flags: TPCCheckFlags);
  1760. begin
  1761. AssertEquals(Path+'.LengthExpr',Orig.LengthExpr,Rest.LengthExpr);
  1762. if Flags=[] then ;
  1763. end;
  1764. procedure TCustomTestPrecompile.CheckRestoredVariable(const Path: string; Orig,
  1765. Rest: TPasVariable; Flags: TPCCheckFlags);
  1766. begin
  1767. CheckRestoredElOrRef(Path+'.VarType',Orig,Orig.VarType,Rest,Rest.VarType,Flags);
  1768. if Orig.VarModifiers<>Rest.VarModifiers then
  1769. Fail(Path+'.VarModifiers');
  1770. CheckRestoredElement(Path+'.LibraryName',Orig.LibraryName,Rest.LibraryName,Flags);
  1771. CheckRestoredElement(Path+'.ExportName',Orig.ExportName,Rest.ExportName,Flags);
  1772. CheckRestoredElement(Path+'.AbsoluteExpr',Orig.AbsoluteExpr,Rest.AbsoluteExpr,Flags);
  1773. CheckRestoredElement(Path+'.Expr',Orig.Expr,Rest.Expr,Flags);
  1774. end;
  1775. procedure TCustomTestPrecompile.CheckRestoredExportSymbol(const Path: string;
  1776. Orig, Rest: TPasExportSymbol; Flags: TPCCheckFlags);
  1777. begin
  1778. CheckRestoredElement(Path+'.NameExpr',Orig.NameExpr,Rest.NameExpr,Flags);
  1779. CheckRestoredElement(Path+'.ExportName',Orig.ExportName,Rest.ExportName,Flags);
  1780. CheckRestoredElement(Path+'.ExportIndex',Orig.ExportIndex,Rest.ExportIndex,Flags);
  1781. end;
  1782. procedure TCustomTestPrecompile.CheckRestoredConst(const Path: string; Orig,
  1783. Rest: TPasConst; Flags: TPCCheckFlags);
  1784. begin
  1785. AssertEquals(Path+'.IsConst',Orig.IsConst,Rest.IsConst);
  1786. CheckRestoredVariable(Path,Orig,Rest,Flags);
  1787. end;
  1788. procedure TCustomTestPrecompile.CheckRestoredProperty(const Path: string; Orig,
  1789. Rest: TPasProperty; Flags: TPCCheckFlags);
  1790. begin
  1791. CheckRestoredElement(Path+'.IndexExpr',Orig.IndexExpr,Rest.IndexExpr,Flags);
  1792. CheckRestoredElement(Path+'.ReadAccessor',Orig.ReadAccessor,Rest.ReadAccessor,Flags);
  1793. CheckRestoredElement(Path+'.WriteAccessor',Orig.WriteAccessor,Rest.WriteAccessor,Flags);
  1794. CheckRestoredElement(Path+'.DispIDExpr',Orig.DispIDExpr,Rest.DispIDExpr,Flags);
  1795. CheckRestoredPasExprArray(Path+'.Implements',Orig.Implements,Rest.Implements,Flags);
  1796. CheckRestoredElement(Path+'.StoredAccessor',Orig.StoredAccessor,Rest.StoredAccessor,Flags);
  1797. CheckRestoredElement(Path+'.DefaultExpr',Orig.DefaultExpr,Rest.DefaultExpr,Flags);
  1798. CheckRestoredElementList(Path+'.Args',Orig.Args,Rest.Args,Flags);
  1799. // not needed: ReadAccessorName, WriteAccessorName, ImplementsName, StoredAccessorName
  1800. AssertEquals(Path+'.DispIDReadOnly',Orig.DispIDReadOnly,Rest.DispIDReadOnly);
  1801. AssertEquals(Path+'.IsDefault',Orig.IsDefault,Rest.IsDefault);
  1802. AssertEquals(Path+'.IsNodefault',Orig.IsNodefault,Rest.IsNodefault);
  1803. CheckRestoredVariable(Path,Orig,Rest,Flags);
  1804. end;
  1805. procedure TCustomTestPrecompile.CheckRestoredMethodResolution(
  1806. const Path: string; Orig, Rest: TPasMethodResolution; Flags: TPCCheckFlags);
  1807. begin
  1808. AssertEquals(Path+'.ProcClass',Orig.ProcClass,Rest.ProcClass);
  1809. CheckRestoredElement(Path+'.InterfaceName',Orig.InterfaceName,Rest.InterfaceName,Flags);
  1810. CheckRestoredElement(Path+'.InterfaceProc',Orig.InterfaceProc,Rest.InterfaceProc,Flags);
  1811. CheckRestoredElement(Path+'.ImplementationProc',Orig.ImplementationProc,Rest.ImplementationProc,Flags);
  1812. end;
  1813. procedure TCustomTestPrecompile.CheckRestoredProcNameParts(const Path: string;
  1814. Orig, Rest: TPasProcedure; Flags: TPCCheckFlags);
  1815. var
  1816. OrigNameParts, RestNameParts: TProcedureNameParts;
  1817. i: Integer;
  1818. SubPath: String;
  1819. OrigTemplates, RestTemplates: TFPList;
  1820. begin
  1821. OrigNameParts:=Orig.NameParts;
  1822. RestNameParts:=Rest.NameParts;
  1823. AssertEquals(Path+'.NameParts<>nil',OrigNameParts<>nil,RestNameParts<>nil);
  1824. if OrigNameParts<>nil then
  1825. begin
  1826. AssertEquals(Path+'.NameParts.Count',OrigNameParts.Count,RestNameParts.Count);
  1827. for i:=0 to OrigNameParts.Count-1 do
  1828. begin
  1829. SubPath:=Path+'.NameParts['+IntToStr(i)+']';
  1830. AssertEquals(SubPath+'.Name',TProcedureNamePart(OrigNameParts[i]).Name,TProcedureNamePart(RestNameParts[i]).Name);
  1831. OrigTemplates:=TProcedureNamePart(OrigNameParts[i]).Templates;
  1832. RestTemplates:=TProcedureNamePart(RestNameParts[i]).Templates;
  1833. CheckRestoredObject(SubPath+'.Templates',OrigTemplates,RestTemplates);
  1834. if OrigTemplates=nil then continue;
  1835. CheckRestoredElementList(SubPath+'.Templates',OrigTemplates,RestTemplates,Flags);
  1836. end;
  1837. end;
  1838. end;
  1839. procedure TCustomTestPrecompile.CheckRestoredProcedure(const Path: string;
  1840. Orig, Rest: TPasProcedure; Flags: TPCCheckFlags);
  1841. var
  1842. RestScope, OrigScope: TPas2JSProcedureScope;
  1843. DeclProc: TPasProcedure;
  1844. begin
  1845. CheckRestoredObject(Path+'.CustomData',Orig.CustomData,Rest.CustomData);
  1846. OrigScope:=Orig.CustomData as TPas2JSProcedureScope;
  1847. RestScope:=Rest.CustomData as TPas2JSProcedureScope;
  1848. if OrigScope=nil then
  1849. exit; // msIgnoreInterfaces
  1850. CheckRestoredReference(Path+'.CustomData[TPas2JSProcedureScope].DeclarationProc [20201018123102]',
  1851. OrigScope.DeclarationProc,RestScope.DeclarationProc);
  1852. AssertEquals(Path+'.CustomData[TPas2JSProcedureScope].ResultVarName [20201018123057]',OrigScope.ResultVarName,RestScope.ResultVarName);
  1853. DeclProc:=RestScope.DeclarationProc;
  1854. if DeclProc=nil then
  1855. begin
  1856. DeclProc:=Rest;
  1857. CheckRestoredProcNameParts(Path,Orig,Rest,Flags);
  1858. CheckRestoredElement(Path+'.ProcType',Orig.ProcType,Rest.ProcType,Flags);
  1859. CheckRestoredElement(Path+'.PublicName',Orig.PublicName,Rest.PublicName,Flags);
  1860. CheckRestoredElement(Path+'.LibrarySymbolName',Orig.LibrarySymbolName,Rest.LibrarySymbolName,Flags);
  1861. CheckRestoredElement(Path+'.LibraryExpr',Orig.LibraryExpr,Rest.LibraryExpr,Flags);
  1862. CheckRestoredElement(Path+'.DispIDExpr',Orig.DispIDExpr,Rest.DispIDExpr,Flags);
  1863. AssertEquals(Path+'.AliasName',Orig.AliasName,Rest.AliasName);
  1864. if Orig.Modifiers<>Rest.Modifiers then
  1865. Fail(Path+'.Modifiers');
  1866. AssertEquals(Path+'.MessageName',Orig.MessageName,Rest.MessageName);
  1867. if Orig.MessageType<>Rest.MessageType then
  1868. Fail(Path+'.MessageType Orig='+PCUProcedureMessageTypeNames[Orig.MessageType]+' Rest='+PCUProcedureMessageTypeNames[Rest.MessageType]);
  1869. end
  1870. else
  1871. begin
  1872. // ImplProc
  1873. if Orig.Modifiers*PCUProcedureModifiersImplProc<>Rest.Modifiers*PCUProcedureModifiersImplProc then
  1874. Fail(Path+'.Impl-Modifiers');
  1875. end;
  1876. // Body
  1877. if Orig.Body<>nil then
  1878. begin
  1879. if not ResolverEngine.ProcCanBePrecompiled(DeclProc) then
  1880. begin
  1881. // generic body
  1882. if OrigScope.ImplJS<>nil then
  1883. Fail(Path+'.CustomData[TPas2JSProcedureScope].ImplJS [20201018123049] OrigScope.ImplJS<>nil');
  1884. if RestScope.ImplJS<>nil then
  1885. Fail(Path+'.CustomData[TPas2JSProcedureScope].ImplJS [20201018123139] RestScope.ImplJS<>nil');
  1886. CheckRestoredProcedureBody(Path+'.Body',Orig.Body,Rest.Body,Flags+[PCCGeneric]);
  1887. end;
  1888. end
  1889. else if Rest.Body<>nil then
  1890. Fail(Path+'.Body<>nil, expected =nil');
  1891. end;
  1892. procedure TCustomTestPrecompile.CheckRestoredOperator(const Path: string; Orig,
  1893. Rest: TPasOperator; Flags: TPCCheckFlags);
  1894. begin
  1895. if Orig.OperatorType<>Rest.OperatorType then
  1896. Fail(Path+'.OperatorType Orig='+PCUOperatorTypeNames[Orig.OperatorType]+' Rest='+PCUOperatorTypeNames[Rest.OperatorType]);
  1897. AssertEquals(Path+'.TokenBased',Orig.TokenBased,Rest.TokenBased);
  1898. CheckRestoredProcedure(Path,Orig,Rest,Flags);
  1899. end;
  1900. procedure TCustomTestPrecompile.CheckRestoredProcedureBody(const Path: string;
  1901. Orig, Rest: TProcedureBody; Flags: TPCCheckFlags);
  1902. begin
  1903. CheckRestoredObject(Path+'.CustomData',Orig.CustomData,Rest.CustomData);
  1904. CheckRestoredDeclarations(Path,Orig,Rest,Flags);
  1905. CheckRestoredElement(Path+'.Body',Orig.Body,Rest.Body,Flags);
  1906. end;
  1907. procedure TCustomTestPrecompile.CheckRestoredAttributes(const Path: string;
  1908. Orig, Rest: TPasAttributes; Flags: TPCCheckFlags);
  1909. begin
  1910. CheckRestoredPasExprArray(Path+'.Calls',Orig.Calls,Rest.Calls,Flags);
  1911. end;
  1912. procedure TCustomTestPrecompile.CheckRestoredImplCommand(const Path: string;
  1913. Orig, Rest: TPasImplCommand; Flags: TPCCheckFlags);
  1914. begin
  1915. if Path='' then ;
  1916. if Flags=[] then ;
  1917. if Orig=nil then ;
  1918. if Rest=nil then ;
  1919. end;
  1920. procedure TCustomTestPrecompile.CheckRestoredImplBeginBlock(const Path: string;
  1921. Orig, Rest: TPasImplBeginBlock; Flags: TPCCheckFlags);
  1922. begin
  1923. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1924. end;
  1925. procedure TCustomTestPrecompile.CheckRestoredImplAsmStatement(
  1926. const Path: string; Orig, Rest: TPasImplAsmStatement; Flags: TPCCheckFlags);
  1927. begin
  1928. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1929. CheckRestoredStringList(Path+'.Tokens',Orig.Tokens,Rest.Tokens);
  1930. end;
  1931. procedure TCustomTestPrecompile.CheckRestoredImplRepeatUntil(
  1932. const Path: string; Orig, Rest: TPasImplRepeatUntil; Flags: TPCCheckFlags);
  1933. begin
  1934. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1935. CheckRestoredElement(Path+'.ConditionExpr',Orig.ConditionExpr,Rest.ConditionExpr,Flags);
  1936. end;
  1937. procedure TCustomTestPrecompile.CheckRestoredImplIfElse(const Path: string;
  1938. Orig, Rest: TPasImplIfElse; Flags: TPCCheckFlags);
  1939. begin
  1940. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1941. CheckRestoredElement(Path+'.ConditionExpr',Orig.ConditionExpr,Rest.ConditionExpr,Flags);
  1942. CheckRestoredElement(Path+'.IfBranch',Orig.IfBranch,Rest.IfBranch,Flags);
  1943. CheckRestoredElement(Path+'.ElseBranch',Orig.ElseBranch,Rest.ElseBranch,Flags);
  1944. end;
  1945. procedure TCustomTestPrecompile.CheckRestoredImplWhileDo(const Path: string;
  1946. Orig, Rest: TPasImplWhileDo; Flags: TPCCheckFlags);
  1947. begin
  1948. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1949. CheckRestoredElement(Path+'.ConditionExpr',Orig.ConditionExpr,Rest.ConditionExpr,Flags);
  1950. CheckRestoredElement(Path+'.Body',Orig.Body,Rest.Body,Flags);
  1951. end;
  1952. procedure TCustomTestPrecompile.CheckRestoredImplWithDo(const Path: string;
  1953. Orig, Rest: TPasImplWithDo; Flags: TPCCheckFlags);
  1954. begin
  1955. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1956. CheckRestoredElementList(Path+'.ConditionExpr',Orig.Expressions,Rest.Expressions,Flags);
  1957. CheckRestoredElement(Path+'.Body',Orig.Body,Rest.Body,Flags);
  1958. end;
  1959. procedure TCustomTestPrecompile.CheckRestoredImplCaseOf(const Path: string;
  1960. Orig, Rest: TPasImplCaseOf; Flags: TPCCheckFlags);
  1961. begin
  1962. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1963. CheckRestoredElement(Path+'.CaseExpr',Orig.CaseExpr,Rest.CaseExpr,Flags);
  1964. CheckRestoredElement(Path+'.ElseBranch',Orig.ElseBranch,Rest.ElseBranch,Flags);
  1965. end;
  1966. procedure TCustomTestPrecompile.CheckRestoredImplCaseStatement(
  1967. const Path: string; Orig, Rest: TPasImplCaseStatement; Flags: TPCCheckFlags);
  1968. begin
  1969. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1970. CheckRestoredElementList(Path+'.Expressions',Orig.Expressions,Rest.Expressions,Flags);
  1971. CheckRestoredElement(Path+'.Body',Orig.Body,Rest.Body,Flags);
  1972. end;
  1973. procedure TCustomTestPrecompile.CheckRestoredImplCaseElse(const Path: string;
  1974. Orig, Rest: TPasImplCaseElse; Flags: TPCCheckFlags);
  1975. begin
  1976. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1977. end;
  1978. procedure TCustomTestPrecompile.CheckRestoredImplForLoop(const Path: string;
  1979. Orig, Rest: TPasImplForLoop; Flags: TPCCheckFlags);
  1980. begin
  1981. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  1982. if Orig.LoopType<>Rest.LoopType then
  1983. AssertEquals(Path+'.LoopType',PCUForLoopType[Orig.LoopType],PCUForLoopType[Rest.LoopType]);
  1984. CheckRestoredElement(Path+'.VariableName',Orig.VariableName,Rest.VariableName,Flags);
  1985. CheckRestoredElement(Path+'.StartExpr',Orig.StartExpr,Rest.StartExpr,Flags);
  1986. CheckRestoredElement(Path+'.EndExpr',Orig.EndExpr,Rest.EndExpr,Flags);
  1987. CheckRestoredElement(Path+'.Body',Orig.Body,Rest.Body,Flags);
  1988. CheckRestoredElement(Path+'.Variable',Orig.Variable,Rest.Variable,Flags);
  1989. end;
  1990. procedure TCustomTestPrecompile.CheckRestoredImplAssign(const Path: string;
  1991. Orig, Rest: TPasImplAssign; Flags: TPCCheckFlags);
  1992. begin
  1993. CheckRestoredElement(Path+'.left',Orig.Left,Rest.Left,Flags);
  1994. CheckRestoredElement(Path+'.right',Orig.Right,Rest.Right,Flags);
  1995. end;
  1996. procedure TCustomTestPrecompile.CheckRestoredImplSimple(const Path: string;
  1997. Orig, Rest: TPasImplSimple; Flags: TPCCheckFlags);
  1998. begin
  1999. CheckRestoredElement(Path+'.Expr',Orig.Expr,Rest.Expr,Flags);
  2000. end;
  2001. procedure TCustomTestPrecompile.CheckRestoredImplTry(const Path: string; Orig,
  2002. Rest: TPasImplTry; Flags: TPCCheckFlags);
  2003. begin
  2004. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  2005. CheckRestoredElement(Path+'.FinallyExcept',Orig.FinallyExcept,Rest.FinallyExcept,Flags);
  2006. CheckRestoredElement(Path+'.ElseBranch',Orig.ElseBranch,Rest.ElseBranch,Flags);
  2007. end;
  2008. procedure TCustomTestPrecompile.CheckRestoredImplTryHandler(const Path: string;
  2009. Orig, Rest: TPasImplTryHandler; Flags: TPCCheckFlags);
  2010. begin
  2011. CheckRestoredElementList(Path+'.Elements',Orig.Elements,Rest.Elements,Flags);
  2012. end;
  2013. procedure TCustomTestPrecompile.CheckRestoredImplExceptOn(const Path: string;
  2014. Orig, Rest: TPasImplExceptOn; Flags: TPCCheckFlags);
  2015. begin
  2016. CheckRestoredElement(Path+'.VarEl',Orig.VarEl,Rest.VarEl,Flags);
  2017. CheckRestoredElOrRef(Path+'.TypeEl',Orig,Orig.TypeEl,Rest,Rest.TypeEl,Flags);
  2018. CheckRestoredElement(Path+'.Body',Orig.Body,Rest.Body,Flags);
  2019. end;
  2020. procedure TCustomTestPrecompile.CheckRestoredImplRaise(const Path: string;
  2021. Orig, Rest: TPasImplRaise; Flags: TPCCheckFlags);
  2022. begin
  2023. CheckRestoredElement(Path+'.ExceptObject',Orig.ExceptObject,Rest.ExceptObject,Flags);
  2024. CheckRestoredElement(Path+'.ExceptAddr',Orig.ExceptAddr,Rest.ExceptAddr,Flags);
  2025. end;
  2026. { TTestPrecompile }
  2027. procedure TTestPrecompile.Test_Base256VLQ;
  2028. procedure Test(i: TMaxPrecInt);
  2029. var
  2030. s: String;
  2031. p: PByte;
  2032. j: TMaxPrecInt;
  2033. begin
  2034. s:=EncodeVLQ(i);
  2035. p:=PByte(s);
  2036. j:=DecodeVLQ(p);
  2037. if i<>j then
  2038. Fail('Encode/DecodeVLQ OrigIndex='+IntToStr(i)+' Code="'+s+'" NewIndex='+IntToStr(j));
  2039. end;
  2040. procedure TestStr(i: TMaxPrecInt; Expected: string);
  2041. var
  2042. Actual: String;
  2043. begin
  2044. Actual:=EncodeVLQ(i);
  2045. AssertEquals('EncodeVLQ('+IntToStr(i)+')',Expected,Actual);
  2046. end;
  2047. var
  2048. i: Integer;
  2049. begin
  2050. TestStr(0,#0);
  2051. TestStr(1,#2);
  2052. TestStr(-1,#3);
  2053. for i:=-8200 to 8200 do
  2054. Test(i);
  2055. Test(High(TMaxPrecInt));
  2056. Test(High(TMaxPrecInt)-1);
  2057. Test(Low(TMaxPrecInt)+2);
  2058. Test(Low(TMaxPrecInt)+1);
  2059. //Test(Low(TMaxPrecInt)); such a high number is not needed by pastojs
  2060. end;
  2061. procedure TTestPrecompile.TestPC_EmptyUnit;
  2062. begin
  2063. StartUnit(false);
  2064. Add([
  2065. 'interface',
  2066. 'implementation']);
  2067. WriteReadUnit;
  2068. end;
  2069. procedure TTestPrecompile.TestPC_Const;
  2070. begin
  2071. StartUnit(false);
  2072. Add([
  2073. 'interface',
  2074. 'const',
  2075. ' Three = 3;',
  2076. ' FourPlusFive: longint = 4+5 deprecated ''deprtext'';',
  2077. ' Four: byte = +6-2*2 platform;',
  2078. ' Affirmative = true;',
  2079. ' BFalse = false;', // bool lit
  2080. ' NotBFalse = not BFalse;', // boolconst
  2081. ' UnaryMinus = -3;', // unary minus
  2082. ' FloatA = -31.678E-012;', // float lit
  2083. ' HighInt = High(longint);', // func params, built-in function
  2084. ' s = ''abc'';', // string lit
  2085. ' c: char = s[1];', // array params
  2086. ' a: array[1..2] of longint = (3,4);', // anonymous array, range, array values
  2087. ' PI: Double; external name ''Math.PI'';',
  2088. 'resourcestring',
  2089. ' rs = ''rs'';',
  2090. 'implementation']);
  2091. WriteReadUnit;
  2092. end;
  2093. procedure TTestPrecompile.TestPC_Var;
  2094. begin
  2095. StartUnit(false);
  2096. Add([
  2097. 'interface',
  2098. 'var',
  2099. ' FourPlusFive: longint = 4+5 deprecated ''deprtext'';',
  2100. ' e: double external name ''Math.e'';',
  2101. ' AnoArr: array of longint = (1,2,3);',
  2102. ' s: string = ''aaaäö'';',
  2103. ' s2: string = ''😊'';', // 1F60A
  2104. ' a,b: array of longint;',
  2105. 'implementation']);
  2106. WriteReadUnit;
  2107. end;
  2108. procedure TTestPrecompile.TestPC_Enum;
  2109. begin
  2110. StartUnit(false);
  2111. Add([
  2112. 'interface',
  2113. 'type',
  2114. ' TEnum = (red,green,blue);',
  2115. ' TEnumRg = green..blue;',
  2116. ' TArrOfEnum = array of TEnum;',
  2117. ' TArrOfEnumRg = array of TEnumRg;',
  2118. ' TArrEnumOfInt = array[TEnum] of longint;',
  2119. 'var',
  2120. ' HighEnum: TEnum = high(TEnum);',
  2121. 'implementation']);
  2122. WriteReadUnit;
  2123. end;
  2124. procedure TTestPrecompile.TestPC_Set;
  2125. begin
  2126. StartUnit(false);
  2127. Add([
  2128. 'interface',
  2129. 'type',
  2130. ' TEnum = (red,green,blue);',
  2131. ' TEnumRg = green..blue;',
  2132. ' TEnumAlias = TEnum;', // alias
  2133. ' TSetOfEnum = set of TEnum;',
  2134. ' TSetOfEnumRg = set of TEnumRg;',
  2135. ' TSetOfDir = set of (west,east);',
  2136. 'var',
  2137. ' Empty: TSetOfEnum = [];', // empty set lit
  2138. ' All: TSetOfEnum = [low(TEnum)..pred(high(TEnum)),high(TEnum)];', // full set lit, range in set
  2139. 'implementation']);
  2140. WriteReadUnit;
  2141. end;
  2142. procedure TTestPrecompile.TestPC_Set_InFunction;
  2143. begin
  2144. StartUnit(false);
  2145. Add([
  2146. 'interface',
  2147. 'procedure DoIt;',
  2148. 'implementation',
  2149. 'procedure DoIt;',
  2150. 'type',
  2151. ' TEnum = (red,green,blue);',
  2152. ' TEnumRg = green..blue;',
  2153. ' TEnumAlias = TEnum;', // alias
  2154. ' TSetOfEnum = set of TEnum;',
  2155. ' TSetOfEnumRg = set of TEnumRg;',
  2156. ' TSetOfDir = set of (west,east);',
  2157. 'var',
  2158. ' Empty: TSetOfEnum = [];', // empty set lit
  2159. ' All: TSetOfEnum = [low(TEnum)..pred(high(TEnum)),high(TEnum)];', // full set lit, range in set
  2160. ' Dirs: TSetOfDir;',
  2161. 'begin',
  2162. ' Dirs:=[east];',
  2163. 'end;',
  2164. '']);
  2165. WriteReadUnit;
  2166. end;
  2167. procedure TTestPrecompile.TestPC_SetOfAnonymousEnumType;
  2168. begin
  2169. StartUnit(false);
  2170. Add([
  2171. 'interface',
  2172. 'type',
  2173. ' TSetOfDir = set of (west,east);',
  2174. 'implementation']);
  2175. WriteReadUnit;
  2176. end;
  2177. procedure TTestPrecompile.TestPC_Record;
  2178. begin
  2179. StartUnit(false);
  2180. Add([
  2181. '{$ModeSwitch externalclass}',
  2182. 'interface',
  2183. 'type',
  2184. ' TRec = record',
  2185. ' i: longint;',
  2186. ' s: string;',
  2187. ' b: boolean external name ''ext'';',
  2188. ' end;',
  2189. ' P = pointer;', // alias type to built-in type
  2190. ' TArrOfRec = array of TRec;',
  2191. 'var',
  2192. ' r: TRec;', // full set lit, range in set
  2193. 'implementation']);
  2194. WriteReadUnit;
  2195. end;
  2196. procedure TTestPrecompile.TestPC_Record_InFunction;
  2197. begin
  2198. StartUnit(false);
  2199. Add([
  2200. 'interface',
  2201. 'procedure DoIt;',
  2202. 'implementation',
  2203. 'procedure DoIt;',
  2204. 'type',
  2205. ' TRec = record',
  2206. ' i: longint;',
  2207. ' s: string;',
  2208. ' end;',
  2209. ' P = ^TRec;',
  2210. ' TArrOfRec = array of TRec;',
  2211. 'var',
  2212. ' r: TRec;',
  2213. 'begin',
  2214. 'end;']);
  2215. WriteReadUnit;
  2216. end;
  2217. procedure TTestPrecompile.TestPC_RecordAdv;
  2218. begin
  2219. StartUnit(false);
  2220. Add([
  2221. '{$ModeSwitch advancedrecords}',
  2222. 'interface',
  2223. 'type',
  2224. ' TRec = record',
  2225. ' private',
  2226. ' FInt: longint;',
  2227. ' procedure SetInt(Value: longint);',
  2228. ' function GetItems(Value: word): word;',
  2229. ' procedure SetItems(Index, Value: word);',
  2230. ' public',
  2231. ' property Int: longint read FInt write SetInt default 3;',
  2232. ' property Items[Index: word]: word read GetItems write SetItems; default;',
  2233. ' end;',
  2234. 'var',
  2235. ' r: trec;',
  2236. 'implementation',
  2237. 'procedure TRec.SetInt(Value: longint);',
  2238. 'begin',
  2239. 'end;',
  2240. 'function TRec.GetItems(Value: word): word;',
  2241. 'begin',
  2242. 'end;',
  2243. 'procedure TRec.SetItems(Index, Value: word);',
  2244. 'begin',
  2245. 'end;',
  2246. '']);
  2247. WriteReadUnit;
  2248. end;
  2249. procedure TTestPrecompile.TestPC_JSValue;
  2250. begin
  2251. StartUnit(false);
  2252. Add([
  2253. 'interface',
  2254. 'var',
  2255. ' p: pointer = nil;', // pointer, nil lit
  2256. ' js: jsvalue = 13 div 4;', // jsvalue
  2257. 'implementation']);
  2258. WriteReadUnit;
  2259. end;
  2260. procedure TTestPrecompile.TestPC_Array;
  2261. begin
  2262. StartUnit(false);
  2263. Add([
  2264. 'interface',
  2265. 'type',
  2266. ' TEnum = (red,green);',
  2267. ' TArrInt = array of longint;',
  2268. ' TArrInt2 = array[1..2] of longint;',
  2269. ' TArrEnum1 = array[red..green] of longint;',
  2270. ' TArrEnum2 = array[TEnum] of longint;',
  2271. 'implementation']);
  2272. WriteReadUnit;
  2273. end;
  2274. procedure TTestPrecompile.TestPC_ArrayOfAnonymous;
  2275. begin
  2276. StartUnit(false);
  2277. Add([
  2278. 'interface',
  2279. 'var',
  2280. ' a: array of pointer;',
  2281. 'implementation']);
  2282. WriteReadUnit;
  2283. end;
  2284. procedure TTestPrecompile.TestPC_Array_InFunction;
  2285. begin
  2286. StartUnit(false);
  2287. Add([
  2288. 'interface',
  2289. 'procedure DoIt;',
  2290. 'implementation',
  2291. 'procedure DoIt;',
  2292. 'type',
  2293. ' TArr = array[1..2] of word;',
  2294. 'var',
  2295. ' arr: TArr;',
  2296. 'begin',
  2297. ' arr[2]:=arr[1];',
  2298. 'end;',
  2299. '']);
  2300. WriteReadUnit;
  2301. end;
  2302. procedure TTestPrecompile.TestPC_Proc;
  2303. begin
  2304. StartUnit(false);
  2305. Add([
  2306. 'interface',
  2307. ' function Abs(d: double): double; external name ''Math.Abs'';',
  2308. ' function GetIt(d: double): double;',
  2309. ' procedure DoArgs(const a; var b: array of char; out c: jsvalue); inline;',
  2310. ' procedure DoMulti(a,b: byte);',
  2311. 'implementation',
  2312. 'var k: double;',
  2313. 'function GetIt(d: double): double;',
  2314. 'var j: double;',
  2315. 'begin',
  2316. ' j:=Abs(d+k);',
  2317. ' Result:=j;',
  2318. 'end;',
  2319. 'procedure DoArgs(const a; var b: array of char; out c: jsvalue); inline;',
  2320. 'begin',
  2321. 'end;',
  2322. 'procedure DoMulti(a,b: byte);',
  2323. 'begin',
  2324. 'end;',
  2325. 'procedure NotUsed;',
  2326. 'begin',
  2327. 'end;',
  2328. '']);
  2329. WriteReadUnit;
  2330. end;
  2331. procedure TTestPrecompile.TestPC_Proc_Nested;
  2332. begin
  2333. StartUnit(false);
  2334. Add([
  2335. 'interface',
  2336. ' function GetIt(d: longint): longint;',
  2337. 'implementation',
  2338. 'var k: double;',
  2339. 'function GetIt(d: longint): longint;',
  2340. 'var j: double;',
  2341. ' function GetSum(a,b: longint): longint; forward;',
  2342. ' function GetMul(a,b: longint): longint; ',
  2343. ' begin',
  2344. ' Result:=a*b;',
  2345. ' end;',
  2346. ' function GetSum(a,b: longint): longint;',
  2347. ' begin',
  2348. ' Result:=a+b;',
  2349. ' end;',
  2350. ' procedure NotUsed;',
  2351. ' begin',
  2352. ' end;',
  2353. 'begin',
  2354. ' Result:=GetMul(GetSum(d,2),3);',
  2355. 'end;',
  2356. 'procedure NotUsed;',
  2357. 'begin',
  2358. 'end;',
  2359. '']);
  2360. WriteReadUnit;
  2361. end;
  2362. procedure TTestPrecompile.TestPC_Proc_LocalConst;
  2363. begin
  2364. StartUnit(false);
  2365. Add([
  2366. 'interface',
  2367. 'function GetIt(d: double): double;',
  2368. 'implementation',
  2369. 'function GetIt(d: double): double;',
  2370. 'const',
  2371. ' c: double = 3.3;',
  2372. ' e: double = 2.7;', // e is not used
  2373. 'begin',
  2374. ' Result:=d+c;',
  2375. 'end;',
  2376. '']);
  2377. WriteReadUnit;
  2378. end;
  2379. procedure TTestPrecompile.TestPC_Proc_UTF8;
  2380. begin
  2381. StartUnit(false);
  2382. Add([
  2383. 'interface',
  2384. 'function DoIt: string;',
  2385. 'implementation',
  2386. 'function DoIt: string;',
  2387. 'const',
  2388. ' c = ''äöü😊'';',
  2389. 'begin',
  2390. ' Result:=''ÄÖÜ😊''+c;',
  2391. 'end;',
  2392. '']);
  2393. WriteReadUnit;
  2394. end;
  2395. procedure TTestPrecompile.TestPC_Proc_Arg;
  2396. begin
  2397. StartUnit(false);
  2398. Add([
  2399. 'interface',
  2400. 'procedure DoIt(var a; out b,c: longint; const e,f: array of byte; g: boolean = true);',
  2401. 'implementation',
  2402. 'procedure DoIt(var a; out b,c: longint; const e,f: array of byte; g: boolean = true);',
  2403. 'begin',
  2404. 'end;',
  2405. '']);
  2406. WriteReadUnit;
  2407. end;
  2408. procedure TTestPrecompile.TestPC_ProcType;
  2409. begin
  2410. StartUnit(false);
  2411. Add([
  2412. '{$modeswitch arrayoperators}',
  2413. 'interface',
  2414. 'type',
  2415. ' TProc = procedure;',
  2416. ' TArrProc = array of tproc;',
  2417. 'procedure Mark;',
  2418. 'procedure DoIt(const a: TArrProc);',
  2419. 'implementation',
  2420. 'procedure Mark;',
  2421. 'var',
  2422. ' p: TProc;',
  2423. ' a: TArrProc;',
  2424. 'begin',
  2425. ' DoIt([@Mark,p]+a);',
  2426. 'end;',
  2427. 'procedure DoIt(const a: TArrProc);',
  2428. 'begin',
  2429. 'end;',
  2430. '']);
  2431. WriteReadUnit;
  2432. end;
  2433. procedure TTestPrecompile.TestPC_Proc_Anonymous;
  2434. begin
  2435. StartUnit(false);
  2436. Add([
  2437. 'interface',
  2438. 'type',
  2439. ' TFunc = reference to function(w: word): word;',
  2440. ' function GetIt(f: TFunc): longint;',
  2441. 'implementation',
  2442. 'var k: byte;',
  2443. 'function GetIt(f: TFunc): longint;',
  2444. 'begin',
  2445. ' f:=function(w: word): word',
  2446. ' var j: byte;',
  2447. ' function GetMul(a,b: longint): longint; ',
  2448. ' begin',
  2449. ' Result:=a*b;',
  2450. ' end;',
  2451. ' begin',
  2452. ' Result:=j*GetMul(1,2)*k;',
  2453. ' end;',
  2454. 'end;',
  2455. '']);
  2456. WriteReadUnit;
  2457. end;
  2458. procedure TTestPrecompile.TestPC_Proc_ArrayOfConst;
  2459. begin
  2460. StartUnit(true,[supTVarRec]);
  2461. Add([
  2462. 'interface',
  2463. 'procedure Fly(arr: array of const);',
  2464. 'implementation',
  2465. 'procedure Fly(arr: array of const);',
  2466. 'begin',
  2467. ' if arr[1].VType=1 then ;',
  2468. ' if arr[2].VInteger=1 then ;',
  2469. ' Fly([true,0.3]);',
  2470. 'end;',
  2471. '']);
  2472. WriteReadUnit;
  2473. end;
  2474. procedure TTestPrecompile.TestPC_Class;
  2475. begin
  2476. StartUnit(false);
  2477. Add([
  2478. 'interface',
  2479. 'type',
  2480. ' TObject = class',
  2481. ' protected',
  2482. ' FInt: longint;',
  2483. ' procedure SetInt(Value: longint); virtual; abstract;',
  2484. ' public',
  2485. ' property Int: longint read FInt write SetInt default 3;',
  2486. ' end;',
  2487. ' TBird = class',
  2488. ' protected',
  2489. ' procedure SetInt(Value: longint); override;',
  2490. ' published',
  2491. ' property Int;',
  2492. ' end;',
  2493. 'var',
  2494. ' o: tobject;',
  2495. 'implementation',
  2496. 'procedure TBird.SetInt(Value: longint);',
  2497. 'begin',
  2498. 'end;'
  2499. ]);
  2500. WriteReadUnit;
  2501. end;
  2502. procedure TTestPrecompile.TestPC_ClassForward;
  2503. begin
  2504. Converter.Options:=Converter.Options-[coNoTypeInfo];
  2505. StartUnit(false);
  2506. Add([
  2507. 'interface',
  2508. 'type',
  2509. ' TObject = class end;',
  2510. ' TFish = class;',
  2511. ' TBird = class;',
  2512. ' TBirdClass = class of TBird;',
  2513. ' TFish = class',
  2514. ' B: TBird;',
  2515. ' end;',
  2516. ' TBird = class',
  2517. ' F: TFish;',
  2518. ' end;',
  2519. ' TFishClass = class of TFish;',
  2520. 'var',
  2521. ' b: tbird;',
  2522. ' f: tfish;',
  2523. ' bc: TBirdClass;',
  2524. ' fc: TFishClass;',
  2525. 'implementation',
  2526. 'end.'
  2527. ]);
  2528. WriteReadUnit;
  2529. end;
  2530. procedure TTestPrecompile.TestPC_ClassConstructor;
  2531. begin
  2532. StartUnit(false);
  2533. Add([
  2534. 'interface',
  2535. 'type',
  2536. ' TObject = class',
  2537. ' constructor Create; virtual;',
  2538. ' end;',
  2539. ' TBird = class',
  2540. ' constructor Create; override;',
  2541. ' end;',
  2542. 'procedure DoIt;',
  2543. 'implementation',
  2544. 'constructor TObject.Create;',
  2545. 'begin',
  2546. 'end;',
  2547. 'constructor TBird.Create;',
  2548. 'begin',
  2549. ' inherited;',
  2550. 'end;',
  2551. 'procedure DoIt;',
  2552. 'var b: TBird;',
  2553. 'begin',
  2554. ' b:=TBird.Create;',
  2555. 'end;',
  2556. 'end.'
  2557. ]);
  2558. WriteReadUnit;
  2559. end;
  2560. procedure TTestPrecompile.TestPC_ClassDestructor;
  2561. begin
  2562. StartUnit(false);
  2563. Add([
  2564. 'interface',
  2565. 'type',
  2566. ' TObject = class',
  2567. ' destructor Destroy; virtual;',
  2568. ' end;',
  2569. ' TBird = class',
  2570. ' destructor Destroy; override;',
  2571. ' end;',
  2572. 'procedure DoIt;',
  2573. 'implementation',
  2574. 'destructor TObject.Destroy;',
  2575. 'begin',
  2576. 'end;',
  2577. 'destructor TBird.Destroy;',
  2578. 'begin',
  2579. ' inherited;',
  2580. 'end;',
  2581. 'procedure DoIt;',
  2582. 'var b: TBird;',
  2583. 'begin',
  2584. ' b.Destroy;',
  2585. 'end;',
  2586. 'end.'
  2587. ]);
  2588. WriteReadUnit;
  2589. end;
  2590. procedure TTestPrecompile.TestPC_ClassDispatchMessage;
  2591. begin
  2592. StartUnit(false);
  2593. Add([
  2594. 'interface',
  2595. 'type',
  2596. ' {$DispatchField DispInt}',
  2597. ' {$DispatchStrField DispStr}',
  2598. ' TObject = class',
  2599. ' end;',
  2600. ' THopMsg = record',
  2601. ' DispInt: longint;',
  2602. ' end;',
  2603. ' TPutMsg = record',
  2604. ' DispStr: string;',
  2605. ' end;',
  2606. ' TBird = class',
  2607. ' procedure Fly(var Msg); virtual; abstract; message 2;',
  2608. ' procedure Run; overload; virtual; abstract;',
  2609. ' procedure Run(var Msg); overload; message ''Fast'';',
  2610. ' procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
  2611. ' procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
  2612. ' end;',
  2613. 'implementation',
  2614. 'procedure TBird.Run(var Msg);',
  2615. 'begin',
  2616. 'end;',
  2617. 'end.',
  2618. '']);
  2619. WriteReadUnit;
  2620. end;
  2621. procedure TTestPrecompile.TestPC_Initialization;
  2622. begin
  2623. StartUnit(false);
  2624. Add([
  2625. 'interface',
  2626. 'implementation',
  2627. 'type',
  2628. ' TCaption = string;',
  2629. ' TRec = record h: string; end;',
  2630. 'var',
  2631. ' s: TCaption;',
  2632. ' r: TRec;',
  2633. 'initialization',
  2634. ' s:=''ö😊'';',
  2635. ' r.h:=''Ä😊'';',
  2636. 'end.',
  2637. '']);
  2638. WriteReadUnit;
  2639. end;
  2640. procedure TTestPrecompile.TestPC_BoolSwitches;
  2641. begin
  2642. StartUnit(false);
  2643. Add([
  2644. 'interface',
  2645. '{$R+}',
  2646. '{$C+}',
  2647. 'type',
  2648. ' TObject = class',
  2649. '{$C-}',
  2650. ' procedure DoIt;',
  2651. ' end;',
  2652. '{$C+}',
  2653. 'implementation',
  2654. '{$R-}',
  2655. 'procedure TObject.DoIt;',
  2656. 'begin',
  2657. 'end;',
  2658. '{$C-}',
  2659. 'initialization',
  2660. '{$R+}',
  2661. 'end.',
  2662. '']);
  2663. WriteReadUnit;
  2664. end;
  2665. procedure TTestPrecompile.TestPC_ClassInterface;
  2666. begin
  2667. StartUnit(false);
  2668. Add([
  2669. 'interface',
  2670. '{$interfaces corba}',
  2671. 'type',
  2672. ' IUnknown = interface',
  2673. ' end;',
  2674. ' IFlying = interface',
  2675. ' procedure SetItems(Index: longint; Value: longint);',
  2676. ' end;',
  2677. ' IBird = interface(IFlying)',
  2678. ' [''{D44C1F80-44F9-4E88-8443-C518CCDC1FE8}'']',
  2679. ' function GetItems(Index: longint): longint;',
  2680. ' property Items[Index: longint]: longint read GetItems write SetItems;',
  2681. ' end;',
  2682. ' TObject = class',
  2683. ' end;',
  2684. ' TBird = class(TObject,IBird)',
  2685. ' strict private',
  2686. ' function IBird.GetItems = RetItems;',
  2687. ' function RetItems(Index: longint): longint; virtual; abstract;',
  2688. ' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
  2689. ' end;',
  2690. ' TEagle = class(TObject,IBird)',
  2691. ' strict private',
  2692. ' FBird: IBird;',
  2693. ' property Bird: IBird read FBird implements IBird;',
  2694. ' end;',
  2695. 'implementation',
  2696. 'end.',
  2697. '']);
  2698. WriteReadUnit;
  2699. end;
  2700. procedure TTestPrecompile.TestPC_Attributes;
  2701. begin
  2702. StartUnit(false);
  2703. Add([
  2704. 'interface',
  2705. '{$modeswitch PrefixedAttributes}',
  2706. 'type',
  2707. ' TObject = class',
  2708. ' constructor Create;',
  2709. ' end;',
  2710. ' TCustomAttribute = class',
  2711. ' constructor Create(Id: word);',
  2712. ' end;',
  2713. ' [Missing]',
  2714. ' TBird = class',
  2715. ' [TCustom]',
  2716. ' FField: word;',
  2717. ' end;',
  2718. ' TRec = record',
  2719. ' [TCustom]',
  2720. ' Size: word;',
  2721. ' end;',
  2722. 'var',
  2723. ' [TCustom, TCustom(3)]',
  2724. ' o: TObject;',
  2725. 'implementation',
  2726. '[TCustom]',
  2727. 'constructor TObject.Create; begin end;',
  2728. 'constructor TCustomAttribute.Create(Id: word); begin end;',
  2729. '']);
  2730. WriteReadUnit;
  2731. end;
  2732. procedure TTestPrecompile.TestPC_GenericFunction_Assign;
  2733. begin
  2734. StartUnit(false);
  2735. Parser.Options:=Parser.Options+[po_cassignments];
  2736. Add([
  2737. 'interface',
  2738. 'generic function Run<T>(a: T): T;',
  2739. 'implementation',
  2740. 'generic function Run<T>(a: T): T;',
  2741. 'var b: T;',
  2742. ' i: word;',
  2743. 'begin',
  2744. ' b:=a;',
  2745. ' Result:=b;',
  2746. ' i+=1;',
  2747. 'end;',
  2748. '']);
  2749. WriteReadUnit;
  2750. end;
  2751. procedure TTestPrecompile.TestPC_GenericFunction_Asm;
  2752. begin
  2753. StartUnit(false);
  2754. Add([
  2755. 'interface',
  2756. 'generic function Run<T>(a: T): T;',
  2757. 'generic function Fly<T>(b: T): T;',
  2758. 'implementation',
  2759. 'generic function Run<T>(a: T): T; assembler;',
  2760. 'asm',
  2761. ' console.log(a);',
  2762. 'end;',
  2763. 'generic function Fly<T>(b: T): T;',
  2764. 'begin',
  2765. ' asm end;',
  2766. ' asm',
  2767. ' console.log(b);',
  2768. ' end;',
  2769. 'end;',
  2770. '']);
  2771. WriteReadUnit;
  2772. end;
  2773. procedure TTestPrecompile.TestPC_GenericFunction_RepeatUntil;
  2774. begin
  2775. StartUnit(false);
  2776. Add([
  2777. 'interface',
  2778. 'generic function Run<T>(a: T): T;',
  2779. 'implementation',
  2780. 'generic function Run<T>(a: T): T;',
  2781. 'begin',
  2782. ' repeat until a>1;',
  2783. ' repeat',
  2784. ' Result:=a;',
  2785. ' until false',
  2786. 'end;',
  2787. '']);
  2788. WriteReadUnit;
  2789. end;
  2790. procedure TTestPrecompile.TestPC_GenericFunction_IfElse;
  2791. begin
  2792. StartUnit(false);
  2793. Add([
  2794. 'interface',
  2795. 'generic function Run<T>(a: T): T;',
  2796. 'implementation',
  2797. 'generic function Run<T>(a: T): T;',
  2798. 'begin',
  2799. ' if true then ;',
  2800. ' if false then else ;',
  2801. ' if false then Result:=a else ;',
  2802. ' if false then else Result:=a;',
  2803. ' if true then a:=a else Result:=a;',
  2804. 'end;',
  2805. '']);
  2806. WriteReadUnit;
  2807. end;
  2808. procedure TTestPrecompile.TestPC_GenericFunction_WhileDo;
  2809. begin
  2810. StartUnit(false);
  2811. Add([
  2812. 'interface',
  2813. 'generic function Run<T>(a: T): T;',
  2814. 'implementation',
  2815. 'generic function Run<T>(a: T): T;',
  2816. 'begin',
  2817. ' while true do ;',
  2818. ' while true do a:=a;',
  2819. ' while true do while false do Result:=a;',
  2820. 'end;',
  2821. '']);
  2822. WriteReadUnit;
  2823. end;
  2824. procedure TTestPrecompile.TestPC_GenericFunction_WithDo;
  2825. begin
  2826. StartUnit(false);
  2827. Add([
  2828. 'interface',
  2829. 'type',
  2830. ' TRec = record w: word; end;',
  2831. 'generic function Run<T>(a: T): T;',
  2832. 'implementation',
  2833. 'generic function Run<T>(a: T): T;',
  2834. 'var r,s: TRec;',
  2835. 'begin',
  2836. ' with r do ;',
  2837. ' with r do a:=a;',
  2838. ' with r do begin w:=w; end;',
  2839. ' with r,s do w:=w;',
  2840. ' with r do with s do w:=w;',
  2841. 'end;',
  2842. '']);
  2843. WriteReadUnit;
  2844. end;
  2845. procedure TTestPrecompile.TestPC_GenericFunction_CaseOf;
  2846. begin
  2847. StartUnit(false);
  2848. Add([
  2849. 'interface',
  2850. 'generic function Run<T>(a: T): T;',
  2851. 'implementation',
  2852. 'generic function Run<T>(a: T): T;',
  2853. 'var i,j,k,l,m,n,o: word;',
  2854. 'begin',
  2855. ' case i of',
  2856. ' 1: ;',
  2857. ' end;',
  2858. ' case j of',
  2859. ' 1: ;',
  2860. ' 2..3: ;',
  2861. ' 4,5: ;',
  2862. ' end;',
  2863. ' case k of',
  2864. ' 1: ;',
  2865. ' else',
  2866. ' end;',
  2867. ' case l of',
  2868. ' 1: ;',
  2869. ' else m:=m;',
  2870. ' end;',
  2871. ' case n of',
  2872. ' 1: o:=o;',
  2873. ' end;',
  2874. 'end;',
  2875. '']);
  2876. WriteReadUnit;
  2877. end;
  2878. procedure TTestPrecompile.TestPC_GenericFunction_ForLoop;
  2879. begin
  2880. StartUnit(false);
  2881. Add([
  2882. 'interface',
  2883. 'generic function Run<T>(a: T): T;',
  2884. 'implementation',
  2885. 'generic function Run<T>(a: T): T;',
  2886. 'var i,j,k,l: word;',
  2887. ' c: char;',
  2888. 'begin',
  2889. ' for i:=1 to 3 do ;',
  2890. ' for j:=1+4 to 3*7 do ;',
  2891. ' for k:=-1 to 2 do l:=l;',
  2892. ' for c in char do ;',
  2893. 'end;',
  2894. '']);
  2895. WriteReadUnit;
  2896. end;
  2897. procedure TTestPrecompile.TestPC_GenericFunction_Simple;
  2898. begin
  2899. StartUnit(false);
  2900. Add([
  2901. 'interface',
  2902. 'generic function Run<T>(a: T): T;',
  2903. 'implementation',
  2904. 'procedure Fly(w: word = 0); begin end;',
  2905. 'generic function Run<T>(a: T): T;',
  2906. 'begin',
  2907. ' Fly;',
  2908. ' Fly();',
  2909. ' Fly(3);',
  2910. 'end;',
  2911. '']);
  2912. WriteReadUnit;
  2913. end;
  2914. procedure TTestPrecompile.TestPC_GenericFunction_TryFinally;
  2915. begin
  2916. StartUnit(false);
  2917. Add([
  2918. 'interface',
  2919. 'generic function Run<T>(a: T): T;',
  2920. 'implementation',
  2921. 'generic function Run<T>(a: T): T;',
  2922. 'var i: word;',
  2923. 'begin',
  2924. ' try',
  2925. ' finally;',
  2926. ' end;',
  2927. ' try',
  2928. ' i:=i;',
  2929. ' finally;',
  2930. ' end;',
  2931. ' try',
  2932. ' finally;',
  2933. ' i:=i;',
  2934. ' end;',
  2935. 'end;',
  2936. '']);
  2937. WriteReadUnit;
  2938. end;
  2939. procedure TTestPrecompile.TestPC_GenericFunction_TryExcept;
  2940. begin
  2941. StartUnit(false);
  2942. Add([
  2943. 'interface',
  2944. 'type',
  2945. ' TObject = class end;',
  2946. ' Exception = class Msg: string; end;',
  2947. ' EInvalidCast = class(Exception) end;',
  2948. 'generic function Run<T>(a: T): T;',
  2949. 'implementation',
  2950. 'generic function Run<T>(a: T): T;',
  2951. 'var vI: longint;',
  2952. 'begin',
  2953. ' try',
  2954. ' vi:=1;',
  2955. ' except',
  2956. ' vi:=2',
  2957. ' end;',
  2958. ' try',
  2959. ' except',
  2960. ' raise;',
  2961. ' end;',
  2962. ' try',
  2963. ' VI:=4;',
  2964. ' except',
  2965. ' on einvalidcast do',
  2966. ' raise;',
  2967. ' on E: exception do',
  2968. ' if e.msg='''' then',
  2969. ' raise e;',
  2970. ' else',
  2971. ' vi:=5',
  2972. ' end;',
  2973. ' try',
  2974. ' VI:=6;',
  2975. ' except',
  2976. ' on einvalidcast do ;',
  2977. ' end;',
  2978. 'end;',
  2979. '']);
  2980. WriteReadUnit;
  2981. end;
  2982. procedure TTestPrecompile.TestPC_GenericFunction_LocalProc;
  2983. begin
  2984. StartUnit(false);
  2985. Add([
  2986. 'interface',
  2987. 'generic function Run<T>(a: T): T;',
  2988. 'implementation',
  2989. 'generic function Run<T>(a: T): T;',
  2990. 'var vI: longint;',
  2991. ' procedure SubA; forward;',
  2992. ' procedure SubB;',
  2993. ' begin',
  2994. ' SubA;',
  2995. ' vI:=vI;',
  2996. ' end;',
  2997. ' procedure SubA;',
  2998. ' begin',
  2999. ' SubB;',
  3000. ' vI:=vI;',
  3001. ' end;',
  3002. 'begin',
  3003. ' SubB;',
  3004. 'end;',
  3005. '']);
  3006. WriteReadUnit;
  3007. end;
  3008. procedure TTestPrecompile.TestPC_GenericFunction_AnonymousProc;
  3009. begin
  3010. StartUnit(false);
  3011. Add([
  3012. 'interface',
  3013. 'type',
  3014. ' TFunc = reference to function(x: word): word;',
  3015. 'var Func: TFunc;',
  3016. 'generic function Run<T>(a: T): T;',
  3017. 'implementation',
  3018. 'generic function Run<T>(a: T): T;',
  3019. 'begin',
  3020. ' Func:=function(b:word): word',
  3021. ' begin',
  3022. ' exit(b);',
  3023. ' exit(Result);',
  3024. ' end;',
  3025. 'end;',
  3026. '']);
  3027. WriteReadUnit;
  3028. end;
  3029. procedure TTestPrecompile.TestPC_GenericClass;
  3030. begin
  3031. StartUnit(false);
  3032. Add([
  3033. 'interface',
  3034. 'type',
  3035. ' TObject = class',
  3036. ' end;',
  3037. ' generic TBird<T> = class',
  3038. ' a: T;',
  3039. ' function Run: T;',
  3040. ' end;',
  3041. 'implementation',
  3042. 'function TBird.Run: T;',
  3043. 'var b: T;',
  3044. 'begin',
  3045. ' b:=a; Result:=b;',
  3046. 'end;',
  3047. '']);
  3048. WriteReadUnit;
  3049. end;
  3050. procedure TTestPrecompile.TestPC_GenericMethod;
  3051. begin
  3052. StartUnit(false);
  3053. Add([
  3054. '{$mode delphi}',
  3055. 'interface',
  3056. 'type',
  3057. ' TObject = class',
  3058. ' end;',
  3059. ' TBird = class',
  3060. ' function Run<T>(a: T): T;',
  3061. ' end;',
  3062. 'implementation',
  3063. 'function TBird.Run<T>(a: T): T;',
  3064. 'var b: T;',
  3065. 'begin',
  3066. ' b:=a;',
  3067. ' Result:=b;',
  3068. 'end;',
  3069. '']);
  3070. WriteReadUnit;
  3071. end;
  3072. procedure TTestPrecompile.TestPC_SpecializeClassSameUnit;
  3073. begin
  3074. StartUnit(false);
  3075. Add([
  3076. '{$mode delphi}',
  3077. 'interface',
  3078. 'type',
  3079. ' TObject = class',
  3080. ' end;',
  3081. ' TBird<T> = class',
  3082. ' a: T;',
  3083. ' end;',
  3084. ' TBigBird = TBIrd<double>;',
  3085. 'var',
  3086. ' b: TBigBird;',
  3087. 'implementation',
  3088. 'begin',
  3089. ' b.a:=1.3;',
  3090. '']);
  3091. WriteReadUnit;
  3092. end;
  3093. procedure TTestPrecompile.TestPC_Specialize_LocalTypeInUnit;
  3094. begin
  3095. StartUnit(false);
  3096. Add([
  3097. '{$mode delphi}',
  3098. 'interface',
  3099. 'type',
  3100. ' TObject = class',
  3101. ' end;',
  3102. ' TBird<T> = class',
  3103. ' a: T;',
  3104. ' end;',
  3105. ' TDoubleBird = TBIrd<double>;',
  3106. 'var',
  3107. ' db: TDoubleBird;',
  3108. 'procedure Fly;',
  3109. 'implementation',
  3110. 'type',
  3111. ' TWordBird = TBird<word>;',
  3112. 'procedure Run;',
  3113. 'type TShortIntBird = TBird<shortint>;',
  3114. 'var',
  3115. ' shb: TShortIntBird;',
  3116. ' wb: TWordBird;',
  3117. 'begin',
  3118. ' shb.a:=3;',
  3119. ' wb.a:=4;',
  3120. 'end;',
  3121. 'procedure Fly;',
  3122. 'type TByteBird = TBird<byte>;',
  3123. 'var bb: TByteBird;',
  3124. 'begin',
  3125. ' bb.a:=5;',
  3126. ' Run;',
  3127. 'end;',
  3128. 'begin',
  3129. '']);
  3130. WriteReadUnit;
  3131. end;
  3132. procedure TTestPrecompile.TestPC_Specialize_ClassForward;
  3133. begin
  3134. StartUnit(false);
  3135. Add([
  3136. '{$mode delphi}',
  3137. 'interface',
  3138. 'type',
  3139. ' TObject = class',
  3140. ' end;',
  3141. ' TBird<T> = class;',
  3142. ' TAnt = class',
  3143. ' b: TBird<word>;',
  3144. ' end;',
  3145. ' TBird<T> = class',
  3146. ' a: TAnt;',
  3147. ' end;',
  3148. 'procedure Fly;',
  3149. 'implementation',
  3150. 'procedure Fly;',
  3151. 'var b: TBird<Double>;',
  3152. 'begin',
  3153. ' b.a:=nil;',
  3154. 'end;',
  3155. 'begin',
  3156. '']);
  3157. WriteReadUnit;
  3158. end;
  3159. procedure TTestPrecompile.TestPC_InlineSpecialize_LocalTypeInUnit;
  3160. begin
  3161. StartUnit(false);
  3162. Add([
  3163. '{$mode delphi}',
  3164. 'interface',
  3165. 'type',
  3166. ' TObject = class',
  3167. ' constructor Create;',
  3168. ' end;',
  3169. ' TBird<T> = class',
  3170. ' a: T;',
  3171. ' end;',
  3172. 'var',
  3173. ' db: TBIrd<double>;',
  3174. 'procedure Fly;',
  3175. 'implementation',
  3176. 'constructor TObject.Create;',
  3177. 'begin',
  3178. 'end;',
  3179. 'var wb: TBird<word>;',
  3180. 'procedure Run;',
  3181. 'var',
  3182. ' shb: TBird<shortint>;',
  3183. ' bb: TBird<boolean>;',
  3184. 'begin',
  3185. ' shb.a:=3;',
  3186. ' wb.a:=4;',
  3187. ' bb.a:=true;',
  3188. ' TBird<string>.Create;',
  3189. 'end;',
  3190. 'procedure Fly;',
  3191. 'var lb: TBird<longint>;',
  3192. 'begin',
  3193. ' lb.a:=5;',
  3194. ' Run;',
  3195. 'end;',
  3196. 'begin',
  3197. '']);
  3198. WriteReadUnit;
  3199. end;
  3200. procedure TTestPrecompile.TestPC_Specialize_Array;
  3201. begin
  3202. StartUnit(false);
  3203. Add([
  3204. '{$mode delphi}',
  3205. 'interface',
  3206. 'type',
  3207. ' TArray<T> = array of T;',
  3208. 'var',
  3209. ' da: TArray<double>;',
  3210. 'procedure Fly;',
  3211. 'implementation',
  3212. 'var wa: TArray<word>;',
  3213. 'procedure Run;',
  3214. 'var',
  3215. ' sha: TArray<shortint>;',
  3216. ' ba: TArray<boolean>;',
  3217. 'begin',
  3218. ' sha[1]:=3;',
  3219. ' wa[2]:=4;',
  3220. ' ba[3]:=true;',
  3221. 'end;',
  3222. 'procedure Fly;',
  3223. 'var la: TArray<longint>;',
  3224. 'begin',
  3225. ' la[4]:=5;',
  3226. ' Run;',
  3227. 'end;',
  3228. 'begin',
  3229. '']);
  3230. WriteReadUnit;
  3231. end;
  3232. procedure TTestPrecompile.TestPC_Specialize_ProcType;
  3233. begin
  3234. StartUnit(false);
  3235. Add([
  3236. '{$mode delphi}',
  3237. 'interface',
  3238. 'type',
  3239. ' TFunc<R,P> = function(a: P): R;',
  3240. 'var',
  3241. ' a: TFunc<word,double>;',
  3242. 'procedure Fly;',
  3243. 'implementation',
  3244. 'var b: TFunc<byte,word>;',
  3245. 'procedure Run;',
  3246. 'var',
  3247. ' c: TFunc<shortint,string>;',
  3248. 'begin',
  3249. ' a(3.3);',
  3250. ' b(4);',
  3251. ' c(''abc'');',
  3252. 'end;',
  3253. 'procedure Fly;',
  3254. 'var d: TFunc<longint,boolean>;',
  3255. 'begin',
  3256. ' d(true);',
  3257. ' Run;',
  3258. 'end;',
  3259. 'begin',
  3260. '']);
  3261. WriteReadUnit;
  3262. end;
  3263. procedure TTestPrecompile.TestPC_Constraints;
  3264. begin
  3265. StartUnit(true,[supTObject]);
  3266. Add([
  3267. '{$mode delphi}',
  3268. 'interface',
  3269. 'type',
  3270. ' TBird<T: class> = class',
  3271. ' end;',
  3272. ' TEagle<T: record> = class',
  3273. ' end;',
  3274. ' TAnt<T: constructor> = class',
  3275. ' end;',
  3276. ' TFish = class end;',
  3277. ' TBirdFish = TBird<TFish>;',
  3278. ' TAntFish = TAnt<TFish>;',
  3279. ' TWater<T: TFish> = class',
  3280. ' end;',
  3281. ' TRec = record end;',
  3282. 'var',
  3283. ' bf: TBirdFish;',
  3284. ' af: TAntFish;',
  3285. ' er: TEagle<TRec>;',
  3286. ' wf: TWater<TFish>;',
  3287. 'implementation',
  3288. '']);
  3289. WriteReadUnit;
  3290. end;
  3291. procedure TTestPrecompile.TestPC_GenericClass_InlineSpecialize;
  3292. begin
  3293. StartUnit(true,[supTObject]);
  3294. Add([
  3295. '{$mode delphi}',
  3296. 'interface',
  3297. 'type',
  3298. ' TBird<T: class> = class',
  3299. ' end;',
  3300. ' TEagle<T: class> = class(TBird<T>)',
  3301. ' type',
  3302. ' TMyEagle = TEagle<T>;',
  3303. ' function Fly(v: T): T;',
  3304. ' end;',
  3305. 'implementation',
  3306. 'function TEagle<T>.Fly(v: T): T;',
  3307. 'begin',
  3308. ' TEagle<T>.Create;',
  3309. 'end;',
  3310. '']);
  3311. WriteReadUnit;
  3312. end;
  3313. procedure TTestPrecompile.TestPC_UseUnit;
  3314. begin
  3315. AddModuleWithIntfImplSrc('unit2.pp',
  3316. LinesToStr([
  3317. 'type',
  3318. ' TColor = longint;',
  3319. ' TRec = record h: TColor; end;',
  3320. ' TEnum = (red,green);',
  3321. 'var',
  3322. ' c: TColor;',
  3323. ' r: TRec;',
  3324. ' e: TEnum;']),
  3325. LinesToStr([
  3326. '']));
  3327. StartUnit(true);
  3328. Add([
  3329. 'interface',
  3330. 'uses unit2;',
  3331. 'var',
  3332. ' i: system.longint;',
  3333. ' e2: TEnum;',
  3334. 'implementation',
  3335. 'initialization',
  3336. ' c:=1;',
  3337. ' r.h:=2;',
  3338. ' e:=red;',
  3339. 'end.',
  3340. '']);
  3341. WriteReadUnit;
  3342. end;
  3343. procedure TTestPrecompile.TestPC_UseUnit_Class;
  3344. begin
  3345. AddModuleWithIntfImplSrc('unit2.pp',
  3346. LinesToStr([
  3347. 'type',
  3348. ' TObject = class',
  3349. ' private',
  3350. ' FA: longint;',
  3351. ' public',
  3352. ' type',
  3353. ' TEnum = (red,green);',
  3354. ' public',
  3355. ' i: longint;',
  3356. ' e: TEnum;',
  3357. ' procedure DoIt; virtual; abstract;',
  3358. ' property A: longint read FA write FA;',
  3359. ' end;',
  3360. 'var',
  3361. ' o: TObject;']),
  3362. LinesToStr([
  3363. '']));
  3364. StartUnit(true);
  3365. Add([
  3366. 'interface',
  3367. 'uses unit2;',
  3368. 'var',
  3369. ' b: TObject;',
  3370. 'implementation',
  3371. 'initialization',
  3372. ' o.DoIt;',
  3373. ' o.i:=b.A;',
  3374. ' o.e:=red;',
  3375. 'end.',
  3376. '']);
  3377. WriteReadUnit;
  3378. end;
  3379. procedure TTestPrecompile.TestPC_UseIndirectUnit;
  3380. begin
  3381. AddModuleWithIntfImplSrc('unit2.pp',
  3382. LinesToStr([
  3383. 'type',
  3384. ' TObject = class',
  3385. ' public',
  3386. ' i: longint;',
  3387. ' end;']),
  3388. LinesToStr([
  3389. '']));
  3390. AddModuleWithIntfImplSrc('unit1.pp',
  3391. LinesToStr([
  3392. 'uses unit2;',
  3393. 'var o: TObject;']),
  3394. LinesToStr([
  3395. '']));
  3396. StartUnit(true);
  3397. Add([
  3398. 'interface',
  3399. 'uses unit1;',
  3400. 'implementation',
  3401. 'initialization',
  3402. ' o.i:=3;',
  3403. 'end.',
  3404. '']);
  3405. WriteReadUnit;
  3406. end;
  3407. Initialization
  3408. RegisterTests([TTestPrecompile]);
  3409. RegisterPCUFormat;
  3410. end.