diff options
Diffstat (limited to 'avx512-0037785/packages/pastojs/tests/tcfiler.pas')
| -rw-r--r-- | avx512-0037785/packages/pastojs/tests/tcfiler.pas | 559 |
1 files changed, 507 insertions, 52 deletions
diff --git a/avx512-0037785/packages/pastojs/tests/tcfiler.pas b/avx512-0037785/packages/pastojs/tests/tcfiler.pas index 7b347f96ca..e08cbfc904 100644 --- a/avx512-0037785/packages/pastojs/tests/tcfiler.pas +++ b/avx512-0037785/packages/pastojs/tests/tcfiler.pas @@ -35,6 +35,11 @@ type ); TPCCheckFlags = set of TPCCheckFlag; + TPCCheckedElementPair = class + public + Orig, Rest: TPasElement; + end; + { TCustomTestPrecompile } TCustomTestPrecompile = Class(TCustomTestModule) @@ -44,6 +49,7 @@ type FPCUReader: TPCUReader; FPCUWriter: TPCUWriter; FRestAnalyzer: TPas2JSAnalyzer; + FCheckedElements: TPasAnalyzerKeySet; // keyset of TPCCheckedElementPair, key is Orig procedure OnFilerGetSrc(Sender: TObject; aFilename: string; out p: PChar; out Count: integer); function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean; @@ -70,6 +76,7 @@ type procedure CheckRestoredElementBase(const Path: string; Orig, Rest: TPasElementBase; Flags: TPCCheckFlags); virtual; procedure CheckRestoredResolveData(const Path: string; Orig, Rest: TResolveData; Flags: TPCCheckFlags); virtual; procedure CheckRestoredPasScope(const Path: string; Orig, Rest: TPasScope; Flags: TPCCheckFlags); virtual; + procedure CheckRestoredLocalVar(const Path: string; Orig, Rest: TPas2JSStoredLocalVar); virtual; procedure CheckRestoredModuleScope(const Path: string; Orig, Rest: TPas2JSModuleScope; Flags: TPCCheckFlags); virtual; procedure CheckRestoredIdentifierScope(const Path: string; Orig, Rest: TPasIdentifierScope; Flags: TPCCheckFlags); virtual; procedure CheckRestoredSectionScope(const Path: string; Orig, Rest: TPas2JSSectionScope; Flags: TPCCheckFlags); virtual; @@ -78,6 +85,9 @@ type procedure CheckRestoredRecordScope(const Path: string; Orig, Rest: TPas2jsRecordScope; Flags: TPCCheckFlags); virtual; procedure CheckRestoredClassScope(const Path: string; Orig, Rest: TPas2JSClassScope; Flags: TPCCheckFlags); virtual; procedure CheckRestoredProcScope(const Path: string; Orig, Rest: TPas2JSProcedureScope; Flags: TPCCheckFlags); virtual; + procedure CheckRestoredProcTypeScope(const Path: string; Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags); virtual; + procedure CheckRestoredArrayScope(const Path: string; Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags); virtual; + procedure CheckRestoredPrecompiledJS(const Path: string; OrigEl: TPasElement; Orig: TPas2JSPrecompiledJS; RestEl: TPasElement; Rest: TPas2JSPrecompiledJS; Flags: TPCCheckFlags); virtual; procedure CheckRestoredScopeRefs(const Path: string; Orig, Rest: TPasScopeReferences; Flags: TPCCheckFlags); virtual; procedure CheckRestoredPropertyScope(const Path: string; Orig, Rest: TPasPropertyScope; Flags: TPCCheckFlags); virtual; procedure CheckRestoredGenericParamScope(const Path: string; Orig, Rest: TPasGenericParamsScope; Flags: TPCCheckFlags); virtual; @@ -211,26 +221,19 @@ type procedure TestPC_GenericFunction_AnonymousProc; procedure TestPC_GenericClass; procedure TestPC_GenericMethod; - procedure TestPC_SpecializeClassSameUnit; // ToDo - // ToDo: specialize local generic type in unit interface - // ToDo: specialize local generic type in unit implementation - // ToDo: specialize local generic type in proc decl - // ToDo: specialize local generic type in proc body - // ToDo: inline specialize local generic type in unit interface - // ToDo: inline specialize local generic type in unit implementation - // ToDo: inline specialize local generic type in proc decl - // ToDo: inline specialize local generic type in proc body - // ToDo: specialize extern generic type in unit interface - // ToDo: specialize extern generic type in unit implementation - // ToDo: specialize extern generic type in proc decl - // ToDo: specialize extern generic type in proc body - // ToDo: inline specialize extern generic type in unit interface - // ToDo: inline specialize extern generic type in unit implementation - // ToDo: inline specialize extern generic type in proc decl - // ToDo: inline specialize extern generic type in proc body + // ToDo: GenericMethod Calls, ProcTypes + procedure TestPC_SpecializeClassSameUnit; + procedure TestPC_Specialize_LocalTypeInUnit; + procedure TestPC_Specialize_ClassForward; + procedure TestPC_InlineSpecialize_LocalTypeInUnit; + procedure TestPC_Specialize_Array; + procedure TestPC_Specialize_ProcType; // ToDo: half specialize TBird<T> = class a: TAnt<word,T>; end; // ToDo: no specialize: TBird<T> = class a: TBird<T>; end; + procedure TestPC_Constraints; // ToDo: constraints + // ToDo: unit impl declarations used by generics + procedure TestPC_GenericClass_InlineSpecialize; procedure TestPC_UseUnit; procedure TestPC_UseUnit_Class; @@ -238,6 +241,8 @@ type end; function CompareListOfProcScopeRef(Item1, Item2: Pointer): integer; +function CompareCheckedElementPairs(Item1, Item2: Pointer): integer; +function CompareElWithCheckedElementPair(Key, Item: Pointer): integer; implementation @@ -246,11 +251,27 @@ var Ref1: TPasScopeReference absolute Item1; Ref2: TPasScopeReference absolute Item2; begin - Result:=CompareText(Ref1.Element.Name,Ref2.Element.Name); + Result:=CompareText(GetObjPath(Ref1.Element),GetObjPath(Ref2.Element)); if Result<>0 then exit; Result:=ComparePointer(Ref1.Element,Ref2.Element); end; +function CompareCheckedElementPairs(Item1, Item2: Pointer): integer; +var + Pair1: TPCCheckedElementPair absolute Item1; + Pair2: TPCCheckedElementPair absolute Item2; +begin + Result:=ComparePointer(Pair1.Orig,Pair2.Orig); +end; + +function CompareElWithCheckedElementPair(Key, Item: Pointer): integer; +var + El: TPasElement absolute Key; + Pair: TPCCheckedElementPair absolute Item; +begin + Result:=ComparePointer(El,Pair.Orig); +end; + { TCustomTestPrecompile } procedure TCustomTestPrecompile.OnFilerGetSrc(Sender: TObject; @@ -348,6 +369,7 @@ begin inherited SetUp; FInitialFlags:=TPCUInitialFlags.Create; FAnalyzer:=TPas2JSAnalyzer.Create; + FCheckedElements:=TPasAnalyzerKeySet.Create(@CompareCheckedElementPairs,@CompareElWithCheckedElementPair); Analyzer.Resolver:=Engine; Analyzer.Options:=Analyzer.Options+[paoImplReferences]; Converter.OnIsElementUsed:=@OnConverterIsElementUsed; @@ -356,6 +378,11 @@ end; procedure TCustomTestPrecompile.TearDown; begin + if FCheckedElements<>nil then + begin + FCheckedElements.FreeItems; + FreeAndNil(FCheckedElements); + end; FreeAndNil(FAnalyzer); FreeAndNil(FPCUWriter); FreeAndNil(FPCUReader); @@ -390,6 +417,7 @@ var begin InitialParserOptions:=Parser.Options; Analyzer.Options:=Analyzer.Options+[paoSkipGenericProc]; + Converter.Options:=Converter.Options+[coShortRefGlobals]; ConvertUnit; FPCUWriter:=TPCUWriter.Create; @@ -534,13 +562,13 @@ begin if Orig=nil then begin if Rest<>nil then - Fail(Path+': Orig=nil Rest='+GetObjName(Rest)); + Fail(Path+': Orig=nil Rest='+GetObjPath(Rest)); exit(false); end else if Rest=nil then - Fail(Path+': Orig='+GetObjName(Orig)+' Rest=nil'); + Fail(Path+': Orig='+GetObjPath(Orig)+' Rest=nil'); if Orig.ClassType<>Rest.ClassType then - Fail(Path+': Orig='+GetObjName(Orig)+' Rest='+GetObjName(Rest)); + Fail(Path+': Orig='+GetObjPath(Orig)+' Rest='+GetObjPath(Rest)); Result:=true; end; @@ -607,25 +635,107 @@ end; procedure TCustomTestPrecompile.CheckRestoredDeclarations(const Path: string; Orig, Rest: TPasDeclarations; Flags: TPCCheckFlags); + + function IsSpecialization(El: TPasElement): boolean; + begin + Result:=(El.CustomData is TPasGenericScope) + and (TPasGenericScope(El.CustomData).SpecializedFromItem<>nil); + end; + + function GetSubPath(const Path: string; OrigIndex: integer; OrigDecl: TPasElement): string; + begin + Result:=Path+'['+IntToStr(OrigIndex)+']'; + if OrigDecl.Name<>'' then + Result:=Result+'"'+OrigDecl.Name+'"' + else + Result:=Result+'?noname?'; + end; + +{ procedure WriteList; + var + i: Integer; + begin + writeln('CheckRestoredDeclarations.WriteList'); + for i:=0 to Orig.Declarations.Count-1 do + if i<Rest.Declarations.Count then + writeln(' ',i,' Orig=',TPasElement(Orig.Declarations[i]).Name,' Rest=',TPasElement(Rest.Declarations[i]).Name); + end;} + var - i: Integer; + OrigIndex, RestIndex: Integer; OrigDecl, RestDecl: TPasElement; SubPath: String; begin - for i:=0 to Orig.Declarations.Count-1 do + //WriteList; + // check non specializations + RestIndex:=0; + for OrigIndex:=0 to Orig.Declarations.Count-1 do begin - OrigDecl:=TPasElement(Orig.Declarations[i]); - if i>=Rest.Declarations.Count then - AssertEquals(Path+'.Declarations.Count',Orig.Declarations.Count,Rest.Declarations.Count); - RestDecl:=TPasElement(Rest.Declarations[i]); - SubPath:=Path+'['+IntToStr(i)+']'; - if OrigDecl.Name<>'' then - SubPath:=SubPath+'"'+OrigDecl.Name+'"' - else - SubPath:=SubPath+'?noname?'; + OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]); + if IsSpecialization(OrigDecl) then + continue; + SubPath:=GetSubPath(Path,OrigIndex,OrigDecl); + // skip to next non specialization in restored declarations + while RestIndex<Rest.Declarations.Count do + begin + RestDecl:=TPasElement(Rest.Declarations[RestIndex]); + if not IsSpecialization(RestDecl) then + break; + inc(RestIndex) + end; + if RestIndex=Rest.Declarations.Count then + Fail(SubPath+' missing in restored Declarations'); + // check + CheckRestoredElement(SubPath,OrigDecl,RestDecl,Flags); + inc(RestIndex); + end; + + // check specializations + for OrigIndex:=0 to Orig.Declarations.Count-1 do + begin + OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]); + if not IsSpecialization(OrigDecl) then + continue; + SubPath:=GetSubPath(Path,OrigIndex,OrigDecl); + // search specialization with same name + RestIndex:=0; + repeat + if RestIndex=Rest.Declarations.Count then + Fail(SubPath+' missing in restored Declarations'); + RestDecl:=TPasElement(Rest.Declarations[RestIndex]); + if IsSpecialization(RestDecl) and (OrigDecl.Name=RestDecl.Name) then + break; + inc(RestIndex); + until false; + + if (OrigIndex<Rest.Declarations.Count) and (OrigIndex<>RestIndex) then + begin + // move restored element to original place to generate the same JS + //writeln('TCustomTestPrecompile.CheckRestoredDeclarations Orig[',OrigIndex,']=',GetObjName(OrigDecl),' Rest[',RestIndex,']=',GetObjName(RestDecl)); + if RestIndex>OrigIndex then + Rest.Declarations.Move(RestIndex,OrigIndex) + else + Rest.Declarations.Exchange(RestIndex,OrigIndex); + //writeln('TCustomTestPrecompile.CheckRestoredDeclarations RestIndex=',RestIndex,' ->',OrigIndex); + //WriteList; + end; + + // check CheckRestoredElement(SubPath,OrigDecl,RestDecl,Flags); end; AssertEquals(Path+'.Declarations.Count',Orig.Declarations.Count,Rest.Declarations.Count); + + //WriteList; + for OrigIndex:=0 to Orig.Declarations.Count-1 do + begin + OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]); + RestDecl:=TPasElement(Rest.Declarations[OrigIndex]); + if OrigDecl.Name<>RestDecl.Name then + begin + SubPath:=GetSubPath(Path,OrigIndex,OrigDecl); + AssertEquals(SubPath+'.Name',GetObjPath(OrigDecl),GetObjPath(RestDecl)); + end; + end; end; procedure TCustomTestPrecompile.CheckRestoredSection(const Path: string; Orig, @@ -689,8 +799,19 @@ begin CheckRestoredResolveData(Path,Orig,Rest,Flags); end; +procedure TCustomTestPrecompile.CheckRestoredLocalVar(const Path: string; Orig, + Rest: TPas2JSStoredLocalVar); +begin + AssertEquals(Path+'.Name',Orig.Name,Rest.Name); + CheckRestoredReference(Path+'.Id',Orig.Element,Rest.Element); +end; + procedure TCustomTestPrecompile.CheckRestoredModuleScope(const Path: string; Orig, Rest: TPas2JSModuleScope; Flags: TPCCheckFlags); +var + OrigLocalVars, RestLocalVars: TPas2JSStoredLocalVarArray; + i, j: Integer; + OrigLocalVar, RestLocalVar: TPas2JSStoredLocalVar; begin AssertEquals(Path+'.FirstName',Orig.FirstName,Rest.FirstName); if Orig.Flags<>Rest.Flags then @@ -704,6 +825,32 @@ begin CheckRestoredReference(Path+'.RangeErrorConstructor',Orig.RangeErrorConstructor,Rest.RangeErrorConstructor); CheckRestoredReference(Path+'.SystemTVarRec',Orig.SystemTVarRec,Rest.SystemTVarRec); CheckRestoredReference(Path+'.SystemVarRecs',Orig.SystemVarRecs,Rest.SystemVarRecs); + + // StoreJSLocalVars + OrigLocalVars:=Orig.StoreJSLocalVars; + RestLocalVars:=Rest.StoreJSLocalVars; + //for i:=0 to length(RestLocalVars)-1 do + // writeln('TCustomTestPrecompile.CheckRestoredModuleScope Rest ',i,'/',length(RestLocalVars),' ',RestLocalVars[i].Name); + for i:=0 to length(OrigLocalVars)-1 do + begin + OrigLocalVar:=OrigLocalVars[i]; + //writeln('TCustomTestPrecompile.CheckRestoredModuleScope Orig ',i,'/',length(OrigLocalVars),' ',OrigLocalVar.Name); + j:=length(OrigLocalVars)-1; + while (j>=0) do + begin + RestLocalVar:=RestLocalVars[j]; + if OrigLocalVar.Name=RestLocalVar.Name then + begin + CheckRestoredLocalVar(Path+'.LocalVars['+IntToStr(i)+']',OrigLocalVar,RestLocalVar); + break; + end; + dec(j); + end; + if j<0 then + Fail(Path+'.LocalVars['+IntToStr(i)+'] Name="'+OrigLocalVar.Name+'" missing in Rest'); + end; + AssertEquals('LocalVars.Count',length(OrigLocalVars),length(RestLocalVars)); + CheckRestoredPasScope(Path,Orig,Rest,Flags); end; @@ -793,8 +940,7 @@ procedure TCustomTestPrecompile.CheckRestoredInitialFinalizationScope( Flags: TPCCheckFlags); begin CheckRestoredScopeRefs(Path+'.References',Orig.References,Rest.References,Flags); - if Orig.JS<>Rest.JS then - CheckRestoredJS(Path+'.JS',Orig.JS,Rest.JS); + CheckRestoredPrecompiledJS(Path+'.ImplJS',Orig.Element,Orig.ImplJS,Rest.Element,Rest.ImplJS,Flags); end; procedure TCustomTestPrecompile.CheckRestoredEnumTypeScope(const Path: string; @@ -809,6 +955,8 @@ procedure TCustomTestPrecompile.CheckRestoredRecordScope(const Path: string; begin CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty); CheckRestoredIdentifierScope(Path,Orig,Rest,Flags); + // ok -> use same JSName + Rest.JSName:=Orig.JSName; end; procedure TCustomTestPrecompile.CheckRestoredClassScope(const Path: string; @@ -882,6 +1030,9 @@ begin end; CheckRestoredIdentifierScope(Path,Orig,Rest,Flags); + + // ok -> use same JSName + Rest.JSName:=Orig.JSName; end; procedure TCustomTestPrecompile.CheckRestoredProcScope(const Path: string; @@ -891,10 +1042,7 @@ var begin CheckRestoredReference(Path+'.DeclarationProc',Orig.DeclarationProc,Rest.DeclarationProc); CheckRestoredReference(Path+'.ImplProc',Orig.ImplProc,Rest.ImplProc); - if Orig.BodyJS<>Rest.BodyJS then - CheckRestoredJS(Path+'.BodyJS',Orig.BodyJS,Rest.BodyJS); - - CheckRestoredStringList(Path+'.GlobalJS',Orig.GlobalJS,Rest.GlobalJS); + CheckRestoredPrecompiledJS(Path+'.ImplJS',Orig.Element,Orig.ImplJS,Rest.Element,Rest.ImplJS,Flags); if Rest.DeclarationProc=nil then begin @@ -921,6 +1069,47 @@ begin begin // ImplProc end; + + // ok -> use same JSName + Rest.JSName:=Orig.JSName; +end; + +procedure TCustomTestPrecompile.CheckRestoredProcTypeScope(const Path: string; + Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags); +begin + if Path='' then ; + if Flags=[] then ; + + // ok -> use same JSName + Rest.JSName:=Orig.JSName; +end; + +procedure TCustomTestPrecompile.CheckRestoredArrayScope(const Path: string; + Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags); +begin + if Path='' then ; + if Flags=[] then ; + + // ok -> use same JSName + Rest.JSName:=Orig.JSName; +end; + +procedure TCustomTestPrecompile.CheckRestoredPrecompiledJS(const Path: string; + OrigEl: TPasElement; Orig: TPas2JSPrecompiledJS; RestEl: TPasElement; + Rest: TPas2JSPrecompiledJS; Flags: TPCCheckFlags); +begin + CheckRestoredObject(Path,Orig,Rest); + if Orig=nil then exit; + if Flags=[] then ; + + AssertEquals(Path+'.EmptyJS',Orig.EmptyJS,Rest.EmptyJS); + if Orig.BodyJS<>Rest.BodyJS then + CheckRestoredJS(Path+'.BodyJS',Orig.BodyJS,Rest.BodyJS); + if Orig.BodyJS<>'' then + begin + CheckRestoredStringList(Path+'.GlobalJS',Orig.GlobalJS,Rest.GlobalJS); + CheckRestoredElRefList(Path+'.ShortRefs',OrigEl,Orig.ShortRefs,RestEl,Rest.ShortRefs,false,Flags); + end; end; procedure TCustomTestPrecompile.CheckRestoredScopeRefs(const Path: string; @@ -929,12 +1118,14 @@ var OrigList, RestList: TFPList; i: Integer; OrigRef, RestRef: TPasScopeReference; + ok: Boolean; begin if Flags=[] then ; CheckRestoredObject(Path,Orig,Rest); if Orig=nil then exit; OrigList:=nil; RestList:=nil; + ok:=false; try OrigList:=Orig.GetList; RestList:=Rest.GetList; @@ -957,7 +1148,21 @@ begin RestRef:=TPasScopeReference(RestList[i]); Fail(Path+'['+IntToStr(i)+'] Too many in Rest: "'+RestRef.Element.Name+'"'); end; + ok:=true; finally + if not ok then + begin + for i:=0 to OrigList.Count-1 do + begin + OrigRef:=TPasScopeReference(OrigList[i]); + writeln('TCustomTestPrecompile.CheckRestoredScopeRefs Orig[',i,']=',GetObjPath(OrigRef.Element)); + end; + for i:=0 to RestList.Count-1 do + begin + RestRef:=TPasScopeReference(RestList[i]); + writeln('TCustomTestPrecompile.CheckRestoredScopeRefs Rest[',i,']=',GetObjPath(RestRef.Element)); + end; + end; OrigList.Free; RestList.Free; end; @@ -1113,6 +1318,10 @@ begin CheckRestoredClassScope(Path+'[TPas2JSClassScope]',TPas2JSClassScope(Orig),TPas2JSClassScope(Rest),Flags) else if C=TPas2JSProcedureScope then CheckRestoredProcScope(Path+'[TPas2JSProcedureScope]',TPas2JSProcedureScope(Orig),TPas2JSProcedureScope(Rest),Flags) + else if C=TPas2JSArrayScope then + CheckRestoredArrayScope(Path+'[TPas2JSArrayScope]',TPas2JSArrayScope(Orig),TPas2JSArrayScope(Rest),Flags) + else if C=TPas2JSProcTypeScope then + CheckRestoredProcTypeScope(Path+'[TPas2JSProcTypeScope]',TPas2JSProcTypeScope(Orig),TPas2JSProcTypeScope(Rest),Flags) else if C=TPasPropertyScope then CheckRestoredPropertyScope(Path+'[TPasPropertyScope]',TPasPropertyScope(Orig),TPasPropertyScope(Rest),Flags) else if C=TPasGenericParamsScope then @@ -1167,7 +1376,14 @@ begin if RestUsed=nil then Fail(Path+': used in OrigAnalyzer, but not used in RestAnalyzer'); if OrigUsed.Access<>RestUsed.Access then - AssertEquals(Path+'->Analyzer.Access',dbgs(OrigUsed.Access),dbgs(RestUsed.Access)); + begin + if (OrigUsed.Access in [paiaReadWrite,paiaWriteRead]) + and (RestUsed.Access in [paiaReadWrite,paiaWriteRead]) + and not (Orig.Parent is TProcedureBody) then + // readwrite or writeread is irrelevant for globals + else + AssertEquals(Path+'->Analyzer.Access',dbgs(OrigUsed.Access),dbgs(RestUsed.Access)); + end; end else if RestAnalyzer.IsUsed(Rest) then begin @@ -1180,11 +1396,27 @@ procedure TCustomTestPrecompile.CheckRestoredElement(const Path: string; Orig, var C: TClass; AModule: TPasModule; + Pair: TPCCheckedElementPair; begin //writeln('TCustomTestPrecompile.CheckRestoredElement START Orig=',GetObjName(Orig),' Rest=',GetObjName(Rest)); if not CheckRestoredObject(Path,Orig,Rest) then exit; //writeln('TCustomTestPrecompile.CheckRestoredElement CheckRestoredObject Orig=',GetObjName(Orig),' Rest=',GetObjName(Rest)); + Pair:=TPCCheckedElementPair(FCheckedElements.FindKey(Orig)); + if Pair<>nil then + begin + if Pair.Rest<>Rest then + Fail(Path+': Orig='+GetObjPath(Orig)+' Rest='+GetObjPath(Rest)); + exit; + end + else + begin + Pair:=TPCCheckedElementPair.Create; + Pair.Orig:=Orig; + Pair.Rest:=Rest; + FCheckedElements.Add(Pair,false); + end; + AModule:=Orig.GetModule; if AModule<>Module then begin @@ -1703,6 +1935,7 @@ end; procedure TCustomTestPrecompile.CheckRestoredExportSymbol(const Path: string; Orig, Rest: TPasExportSymbol; Flags: TPCCheckFlags); begin + CheckRestoredElement(Path+'.NameExpr',Orig.NameExpr,Rest.NameExpr,Flags); CheckRestoredElement(Path+'.ExportName',Orig.ExportName,Rest.ExportName,Flags); CheckRestoredElement(Path+'.ExportIndex',Orig.ExportIndex,Rest.ExportIndex,Flags); end; @@ -1779,9 +2012,9 @@ begin RestScope:=Rest.CustomData as TPas2JSProcedureScope; if OrigScope=nil then exit; // msIgnoreInterfaces - CheckRestoredReference(Path+'.CustomData[TPas2JSProcedureScope].DeclarationProc', + CheckRestoredReference(Path+'.CustomData[TPas2JSProcedureScope].DeclarationProc [20201018123102]', OrigScope.DeclarationProc,RestScope.DeclarationProc); - AssertEquals(Path+'.CustomData[TPas2JSProcedureScope].ResultVarName',OrigScope.ResultVarName,RestScope.ResultVarName); + AssertEquals(Path+'.CustomData[TPas2JSProcedureScope].ResultVarName [20201018123057]',OrigScope.ResultVarName,RestScope.ResultVarName); DeclProc:=RestScope.DeclarationProc; if DeclProc=nil then begin @@ -1808,15 +2041,13 @@ begin // Body if Orig.Body<>nil then begin - if Engine.ProcCanBePrecompiled(DeclProc) then - begin - AssertEquals(Path+'.EmptyJS',OrigScope.EmptyJS,RestScope.EmptyJS); - CheckRestoredJS(Path+'.BodyJS',OrigScope.BodyJS,RestScope.BodyJS); - CheckRestoredStringList(Path+'.GlobalJS',OrigScope.GlobalJS,RestScope.GlobalJS); - end - else + if not Engine.ProcCanBePrecompiled(DeclProc) then begin // generic body + if OrigScope.ImplJS<>nil then + Fail(Path+'.CustomData[TPas2JSProcedureScope].ImplJS [20201018123049] OrigScope.ImplJS<>nil'); + if RestScope.ImplJS<>nil then + Fail(Path+'.CustomData[TPas2JSProcedureScope].ImplJS [20201018123139] RestScope.ImplJS<>nil'); CheckRestoredProcedureBody(Path+'.Body',Orig.Body,Rest.Body,Flags+[PCCGeneric]); end; end @@ -2730,7 +2961,7 @@ begin 'implementation', 'generic function Run<T>(a: T): T;', 'var b: T;', - ' var i: word;', + ' i: word;', 'begin', ' b:=a;', ' Result:=b;', @@ -3077,8 +3308,6 @@ end; procedure TTestPrecompile.TestPC_SpecializeClassSameUnit; begin - exit; - StartUnit(false); Add([ '{$mode delphi}', @@ -3095,7 +3324,233 @@ begin 'implementation', 'begin', ' b.a:=1.3;', - 'end.', + '']); + WriteReadUnit; +end; + +procedure TTestPrecompile.TestPC_Specialize_LocalTypeInUnit; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TObject = class', + ' end;', + ' TBird<T> = class', + ' a: T;', + ' end;', + ' TDoubleBird = TBIrd<double>;', + 'var', + ' db: TDoubleBird;', + 'procedure Fly;', + 'implementation', + 'type', + ' TWordBird = TBird<word>;', + 'procedure Run;', + 'type TShortIntBird = TBird<shortint>;', + 'var', + ' shb: TShortIntBird;', + ' wb: TWordBird;', + 'begin', + ' shb.a:=3;', + ' wb.a:=4;', + 'end;', + 'procedure Fly;', + 'type TByteBird = TBird<byte>;', + 'var bb: TByteBird;', + 'begin', + ' bb.a:=5;', + ' Run;', + 'end;', + 'begin', + '']); + WriteReadUnit; +end; + +procedure TTestPrecompile.TestPC_Specialize_ClassForward; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TObject = class', + ' end;', + ' TBird<T> = class;', + ' TAnt = class', + ' b: TBird<word>;', + ' end;', + ' TBird<T> = class', + ' a: TAnt;', + ' end;', + 'procedure Fly;', + 'implementation', + 'procedure Fly;', + 'var b: TBird<Double>;', + 'begin', + ' b.a:=nil;', + 'end;', + 'begin', + '']); + WriteReadUnit; +end; + +procedure TTestPrecompile.TestPC_InlineSpecialize_LocalTypeInUnit; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TObject = class', + ' constructor Create;', + ' end;', + ' TBird<T> = class', + ' a: T;', + ' end;', + 'var', + ' db: TBIrd<double>;', + 'procedure Fly;', + 'implementation', + 'constructor TObject.Create;', + 'begin', + 'end;', + 'var wb: TBird<word>;', + 'procedure Run;', + 'var', + ' shb: TBird<shortint>;', + ' bb: TBird<boolean>;', + 'begin', + ' shb.a:=3;', + ' wb.a:=4;', + ' bb.a:=true;', + ' TBird<string>.Create;', + 'end;', + 'procedure Fly;', + 'var lb: TBird<longint>;', + 'begin', + ' lb.a:=5;', + ' Run;', + 'end;', + 'begin', + '']); + WriteReadUnit; +end; + +procedure TTestPrecompile.TestPC_Specialize_Array; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TArray<T> = array of T;', + 'var', + ' da: TArray<double>;', + 'procedure Fly;', + 'implementation', + 'var wa: TArray<word>;', + 'procedure Run;', + 'var', + ' sha: TArray<shortint>;', + ' ba: TArray<boolean>;', + 'begin', + ' sha[1]:=3;', + ' wa[2]:=4;', + ' ba[3]:=true;', + 'end;', + 'procedure Fly;', + 'var la: TArray<longint>;', + 'begin', + ' la[4]:=5;', + ' Run;', + 'end;', + 'begin', + '']); + WriteReadUnit; +end; + +procedure TTestPrecompile.TestPC_Specialize_ProcType; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TFunc<R,P> = function(a: P): R;', + 'var', + ' a: TFunc<word,double>;', + 'procedure Fly;', + 'implementation', + 'var b: TFunc<byte,word>;', + 'procedure Run;', + 'var', + ' c: TFunc<shortint,string>;', + 'begin', + ' a(3.3);', + ' b(4);', + ' c(''abc'');', + 'end;', + 'procedure Fly;', + 'var d: TFunc<longint,boolean>;', + 'begin', + ' d(true);', + ' Run;', + 'end;', + 'begin', + '']); + WriteReadUnit; +end; + +procedure TTestPrecompile.TestPC_Constraints; +begin + StartUnit(true,[supTObject]); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TBird<T: class> = class', + ' end;', + ' TEagle<T: record> = class', + ' end;', + ' TAnt<T: constructor> = class', + ' end;', + ' TFish = class end;', + ' TBirdFish = TBird<TFish>;', + ' TAntFish = TAnt<TFish>;', + ' TWater<T: TFish> = class', + ' end;', + ' TRec = record end;', + 'var', + ' bf: TBirdFish;', + ' af: TAntFish;', + ' er: TEagle<TRec>;', + ' wf: TWater<TFish>;', + 'implementation', + '']); + WriteReadUnit; +end; + +procedure TTestPrecompile.TestPC_GenericClass_InlineSpecialize; +begin + StartUnit(true,[supTObject]); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TBird<T: class> = class', + ' end;', + ' TEagle<T: class> = class(TBird<T>)', + ' type', + ' TMyEagle = TEagle<T>;', + ' function Fly(v: T): T;', + ' end;', + 'implementation', + 'function TEagle<T>.Fly(v: T): T;', + 'begin', + ' TEagle<T>.Create;', + 'end;', '']); WriteReadUnit; end; |