tcfiler.pas 123 KB

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