mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 15:28:01 +02:00
2404 lines
82 KiB
ObjectPascal
2404 lines
82 KiB
ObjectPascal
{
|
|
This file is part of the Free Component Library (FCL)
|
|
Copyright (c) 2018 by Michael Van Canneyt
|
|
|
|
Unit tests for Pascal-to-Javascript precompile class.
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************
|
|
|
|
Examples:
|
|
./testpas2js --suite=TTestPrecompile.TestPC_EmptyUnit
|
|
}
|
|
unit tcfiler;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, fpcunit, testregistry,
|
|
jstree,
|
|
PasTree, PScanner, PParser, PasResolveEval, PasResolver, PasUseAnalyzer,
|
|
Pas2jsUseAnalyzer, FPPas2Js, Pas2JsFiler,
|
|
tcmodules;
|
|
|
|
type
|
|
|
|
{ TCustomTestPrecompile }
|
|
|
|
TCustomTestPrecompile = Class(TCustomTestModule)
|
|
private
|
|
FAnalyzer: TPas2JSAnalyzer;
|
|
FInitialFlags: TPCUInitialFlags;
|
|
FPCUReader: TPCUReader;
|
|
FPCUWriter: TPCUWriter;
|
|
FRestAnalyzer: TPas2JSAnalyzer;
|
|
procedure OnFilerGetSrc(Sender: TObject; aFilename: string; out p: PChar;
|
|
out Count: integer);
|
|
function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
|
|
function OnConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean;
|
|
function OnRestConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
|
|
function OnRestConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean;
|
|
function OnRestResolverFindUnit(const aUnitName: String): TPasModule;
|
|
protected
|
|
procedure SetUp; override;
|
|
procedure TearDown; override;
|
|
function CreateConverter: TPasToJSConverter; override;
|
|
procedure ParseUnit; override;
|
|
procedure WriteReadUnit; virtual;
|
|
procedure StartParsing; override;
|
|
function CheckRestoredObject(const Path: string; Orig, Rest: TObject): boolean; virtual;
|
|
procedure CheckRestoredJS(const Path, Orig, Rest: string); virtual;
|
|
// check restored parser+resolver
|
|
procedure CheckRestoredResolver(Original, Restored: TPas2JSResolver); virtual;
|
|
procedure CheckRestoredDeclarations(const Path: string; Orig, Rest: TPasDeclarations); virtual;
|
|
procedure CheckRestoredSection(const Path: string; Orig, Rest: TPasSection); virtual;
|
|
procedure CheckRestoredModule(const Path: string; Orig, Rest: TPasModule); virtual;
|
|
procedure CheckRestoredScopeReference(const Path: string; Orig, Rest: TPasScope); virtual;
|
|
procedure CheckRestoredElementBase(const Path: string; Orig, Rest: TPasElementBase); virtual;
|
|
procedure CheckRestoredResolveData(const Path: string; Orig, Rest: TResolveData); virtual;
|
|
procedure CheckRestoredPasScope(const Path: string; Orig, Rest: TPasScope); virtual;
|
|
procedure CheckRestoredModuleScope(const Path: string; Orig, Rest: TPas2JSModuleScope); virtual;
|
|
procedure CheckRestoredIdentifierScope(const Path: string; Orig, Rest: TPasIdentifierScope); virtual;
|
|
procedure CheckRestoredSectionScope(const Path: string; Orig, Rest: TPas2JSSectionScope); virtual;
|
|
procedure CheckRestoredInitialFinalizationScope(const Path: string; Orig, Rest: TPas2JSInitialFinalizationScope); virtual;
|
|
procedure CheckRestoredEnumTypeScope(const Path: string; Orig, Rest: TPasEnumTypeScope); virtual;
|
|
procedure CheckRestoredRecordScope(const Path: string; Orig, Rest: TPasRecordScope); virtual;
|
|
procedure CheckRestoredClassScope(const Path: string; Orig, Rest: TPas2JSClassScope); virtual;
|
|
procedure CheckRestoredProcScope(const Path: string; Orig, Rest: TPas2JSProcedureScope); virtual;
|
|
procedure CheckRestoredScopeRefs(const Path: string; Orig, Rest: TPasScopeReferences); virtual;
|
|
procedure CheckRestoredPropertyScope(const Path: string; Orig, Rest: TPasPropertyScope); virtual;
|
|
procedure CheckRestoredResolvedReference(const Path: string; Orig, Rest: TResolvedReference); virtual;
|
|
procedure CheckRestoredEvalValue(const Path: string; Orig, Rest: TResEvalValue); virtual;
|
|
procedure CheckRestoredCustomData(const Path: string; RestoredEl: TPasElement; Orig, Rest: TObject); virtual;
|
|
procedure CheckRestoredReference(const Path: string; Orig, Rest: TPasElement); virtual;
|
|
procedure CheckRestoredElOrRef(const Path: string; Orig, OrigProp, Rest, RestProp: TPasElement); virtual;
|
|
procedure CheckRestoredAnalyzerElement(const Path: string; Orig, Rest: TPasElement); virtual;
|
|
procedure CheckRestoredElement(const Path: string; Orig, Rest: TPasElement); virtual;
|
|
procedure CheckRestoredElementList(const Path: string; Orig, Rest: TFPList); virtual;
|
|
procedure CheckRestoredElRefList(const Path: string; OrigParent: TPasElement;
|
|
Orig: TFPList; RestParent: TPasElement; Rest: TFPList; AllowInSitu: boolean); virtual;
|
|
procedure CheckRestoredPasExpr(const Path: string; Orig, Rest: TPasExpr); virtual;
|
|
procedure CheckRestoredUnaryExpr(const Path: string; Orig, Rest: TUnaryExpr); virtual;
|
|
procedure CheckRestoredBinaryExpr(const Path: string; Orig, Rest: TBinaryExpr); virtual;
|
|
procedure CheckRestoredPrimitiveExpr(const Path: string; Orig, Rest: TPrimitiveExpr); virtual;
|
|
procedure CheckRestoredBoolConstExpr(const Path: string; Orig, Rest: TBoolConstExpr); virtual;
|
|
procedure CheckRestoredParamsExpr(const Path: string; Orig, Rest: TParamsExpr); virtual;
|
|
procedure CheckRestoredProcedureExpr(const Path: string; Orig, Rest: TProcedureExpr); virtual;
|
|
procedure CheckRestoredRecordValues(const Path: string; Orig, Rest: TRecordValues); virtual;
|
|
procedure CheckRestoredPasExprArray(const Path: string; Orig, Rest: TPasExprArray); virtual;
|
|
procedure CheckRestoredArrayValues(const Path: string; Orig, Rest: TArrayValues); virtual;
|
|
procedure CheckRestoredResString(const Path: string; Orig, Rest: TPasResString); virtual;
|
|
procedure CheckRestoredAliasType(const Path: string; Orig, Rest: TPasAliasType); virtual;
|
|
procedure CheckRestoredPointerType(const Path: string; Orig, Rest: TPasPointerType); virtual;
|
|
procedure CheckRestoredSpecializedType(const Path: string; Orig, Rest: TPasSpecializeType); virtual;
|
|
procedure CheckRestoredInlineSpecializedExpr(const Path: string; Orig, Rest: TInlineSpecializeExpr); virtual;
|
|
procedure CheckRestoredRangeType(const Path: string; Orig, Rest: TPasRangeType); virtual;
|
|
procedure CheckRestoredArrayType(const Path: string; Orig, Rest: TPasArrayType); virtual;
|
|
procedure CheckRestoredFileType(const Path: string; Orig, Rest: TPasFileType); virtual;
|
|
procedure CheckRestoredEnumValue(const Path: string; Orig, Rest: TPasEnumValue); virtual;
|
|
procedure CheckRestoredEnumType(const Path: string; Orig, Rest: TPasEnumType); virtual;
|
|
procedure CheckRestoredSetType(const Path: string; Orig, Rest: TPasSetType); virtual;
|
|
procedure CheckRestoredVariant(const Path: string; Orig, Rest: TPasVariant); virtual;
|
|
procedure CheckRestoredRecordType(const Path: string; Orig, Rest: TPasRecordType); virtual;
|
|
procedure CheckRestoredClassType(const Path: string; Orig, Rest: TPasClassType); virtual;
|
|
procedure CheckRestoredArgument(const Path: string; Orig, Rest: TPasArgument); virtual;
|
|
procedure CheckRestoredProcedureType(const Path: string; Orig, Rest: TPasProcedureType); virtual;
|
|
procedure CheckRestoredResultElement(const Path: string; Orig, Rest: TPasResultElement); virtual;
|
|
procedure CheckRestoredFunctionType(const Path: string; Orig, Rest: TPasFunctionType); virtual;
|
|
procedure CheckRestoredStringType(const Path: string; Orig, Rest: TPasStringType); virtual;
|
|
procedure CheckRestoredVariable(const Path: string; Orig, Rest: TPasVariable); virtual;
|
|
procedure CheckRestoredExportSymbol(const Path: string; Orig, Rest: TPasExportSymbol); virtual;
|
|
procedure CheckRestoredConst(const Path: string; Orig, Rest: TPasConst); virtual;
|
|
procedure CheckRestoredProperty(const Path: string; Orig, Rest: TPasProperty); virtual;
|
|
procedure CheckRestoredMethodResolution(const Path: string; Orig, Rest: TPasMethodResolution); virtual;
|
|
procedure CheckRestoredProcedure(const Path: string; Orig, Rest: TPasProcedure); virtual;
|
|
procedure CheckRestoredOperator(const Path: string; Orig, Rest: TPasOperator); virtual;
|
|
procedure CheckRestoredAttributes(const Path: string; Orig, Rest: TPasAttributes); virtual;
|
|
public
|
|
property Analyzer: TPas2JSAnalyzer read FAnalyzer;
|
|
property RestAnalyzer: TPas2JSAnalyzer read FRestAnalyzer;
|
|
property PCUWriter: TPCUWriter read FPCUWriter write FPCUWriter;
|
|
property PCUReader: TPCUReader read FPCUReader write FPCUReader;
|
|
property InitialFlags: TPCUInitialFlags read FInitialFlags;
|
|
end;
|
|
|
|
{ TTestPrecompile }
|
|
|
|
TTestPrecompile = class(TCustomTestPrecompile)
|
|
published
|
|
procedure Test_Base256VLQ;
|
|
procedure TestPC_EmptyUnit;
|
|
|
|
procedure TestPC_Const;
|
|
procedure TestPC_Var;
|
|
procedure TestPC_Enum;
|
|
procedure TestPC_Set;
|
|
procedure TestPC_Set_InFunction;
|
|
procedure TestPC_SetOfAnonymousEnumType;
|
|
procedure TestPC_Record;
|
|
procedure TestPC_Record_InFunction;
|
|
procedure TestPC_RecordAdv;
|
|
procedure TestPC_JSValue;
|
|
procedure TestPC_Array;
|
|
procedure TestPC_ArrayOfAnonymous;
|
|
procedure TestPC_Array_InFunction;
|
|
procedure TestPC_Proc;
|
|
procedure TestPC_Proc_Nested;
|
|
procedure TestPC_Proc_LocalConst;
|
|
procedure TestPC_Proc_UTF8;
|
|
procedure TestPC_Proc_Arg;
|
|
procedure TestPC_ProcType;
|
|
procedure TestPC_Proc_Anonymous;
|
|
procedure TestPC_Proc_ArrayOfConst;
|
|
procedure TestPC_Class;
|
|
procedure TestPC_ClassForward;
|
|
procedure TestPC_ClassConstructor;
|
|
procedure TestPC_ClassDispatchMessage;
|
|
procedure TestPC_Initialization;
|
|
procedure TestPC_BoolSwitches;
|
|
procedure TestPC_ClassInterface;
|
|
procedure TestPC_Attributes;
|
|
|
|
procedure TestPC_UseUnit;
|
|
procedure TestPC_UseUnit_Class;
|
|
procedure TestPC_UseIndirectUnit;
|
|
end;
|
|
|
|
function CompareListOfProcScopeRef(Item1, Item2: Pointer): integer;
|
|
|
|
implementation
|
|
|
|
function CompareListOfProcScopeRef(Item1, Item2: Pointer): integer;
|
|
var
|
|
Ref1: TPasScopeReference absolute Item1;
|
|
Ref2: TPasScopeReference absolute Item2;
|
|
begin
|
|
Result:=CompareText(Ref1.Element.Name,Ref2.Element.Name);
|
|
if Result<>0 then exit;
|
|
Result:=ComparePointer(Ref1.Element,Ref2.Element);
|
|
end;
|
|
|
|
{ TCustomTestPrecompile }
|
|
|
|
procedure TCustomTestPrecompile.OnFilerGetSrc(Sender: TObject;
|
|
aFilename: string; out p: PChar; out Count: integer);
|
|
var
|
|
i: Integer;
|
|
aModule: TTestEnginePasResolver;
|
|
Src: String;
|
|
begin
|
|
for i:=0 to ResolverCount-1 do
|
|
begin
|
|
aModule:=Resolvers[i];
|
|
if aModule.Filename<>aFilename then continue;
|
|
Src:=aModule.Source;
|
|
p:=PChar(Src);
|
|
Count:=length(Src);
|
|
end;
|
|
end;
|
|
|
|
function TCustomTestPrecompile.OnConverterIsElementUsed(Sender: TObject;
|
|
El: TPasElement): boolean;
|
|
begin
|
|
Result:=Analyzer.IsUsed(El);
|
|
end;
|
|
|
|
function TCustomTestPrecompile.OnConverterIsTypeInfoUsed(Sender: TObject;
|
|
El: TPasElement): boolean;
|
|
begin
|
|
Result:=Analyzer.IsTypeInfoUsed(El);
|
|
end;
|
|
|
|
function TCustomTestPrecompile.OnRestConverterIsElementUsed(Sender: TObject;
|
|
El: TPasElement): boolean;
|
|
begin
|
|
Result:=RestAnalyzer.IsUsed(El);
|
|
end;
|
|
|
|
function TCustomTestPrecompile.OnRestConverterIsTypeInfoUsed(Sender: TObject;
|
|
El: TPasElement): boolean;
|
|
begin
|
|
Result:=RestAnalyzer.IsTypeInfoUsed(El);
|
|
end;
|
|
|
|
function TCustomTestPrecompile.OnRestResolverFindUnit(const aUnitName: String
|
|
): TPasModule;
|
|
|
|
function FindRestUnit(Name: string): TPasModule;
|
|
var
|
|
i: Integer;
|
|
CurEngine: TTestEnginePasResolver;
|
|
CurUnitName: String;
|
|
begin
|
|
for i:=0 to ResolverCount-1 do
|
|
begin
|
|
CurEngine:=Resolvers[i];
|
|
CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
|
|
{$IFDEF VerbosePCUFiler}
|
|
//writeln('TCustomTestPrecompile.FindRestUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
|
|
{$ENDIF}
|
|
if CompareText(Name,CurUnitName)=0 then
|
|
begin
|
|
Result:=CurEngine.Module;
|
|
if Result<>nil then
|
|
begin
|
|
{$IFDEF VerbosePCUFiler}
|
|
//writeln('TCustomTestPrecompile.FindRestUnit Found parsed module: ',Result.Filename);
|
|
{$ENDIF}
|
|
exit;
|
|
end;
|
|
{$IFDEF VerbosePCUFiler}
|
|
writeln('TCustomTestPrecompile.FindRestUnit PARSING unit "',CurEngine.Filename,'"');
|
|
{$ENDIF}
|
|
Fail('not parsed');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
DefNamespace: String;
|
|
begin
|
|
if (Pos('.',aUnitName)<1) then
|
|
begin
|
|
DefNamespace:=GetDefaultNamespace;
|
|
if DefNamespace<>'' then
|
|
begin
|
|
Result:=FindRestUnit(DefNamespace+'.'+aUnitName);
|
|
if Result<>nil then exit;
|
|
end;
|
|
end;
|
|
Result:=FindRestUnit(aUnitName);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.SetUp;
|
|
begin
|
|
inherited SetUp;
|
|
FInitialFlags:=TPCUInitialFlags.Create;
|
|
FAnalyzer:=TPas2JSAnalyzer.Create;
|
|
Analyzer.Resolver:=Engine;
|
|
Analyzer.Options:=Analyzer.Options+[paoImplReferences];
|
|
Converter.OnIsElementUsed:=@OnConverterIsElementUsed;
|
|
Converter.OnIsTypeInfoUsed:=@OnConverterIsTypeInfoUsed;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.TearDown;
|
|
begin
|
|
FreeAndNil(FAnalyzer);
|
|
FreeAndNil(FPCUWriter);
|
|
FreeAndNil(FPCUReader);
|
|
FreeAndNil(FInitialFlags);
|
|
inherited TearDown;
|
|
end;
|
|
|
|
function TCustomTestPrecompile.CreateConverter: TPasToJSConverter;
|
|
begin
|
|
Result:=inherited CreateConverter;
|
|
Result.Options:=Result.Options+[coStoreImplJS];
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.ParseUnit;
|
|
begin
|
|
inherited ParseUnit;
|
|
Analyzer.AnalyzeModule(Module);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.WriteReadUnit;
|
|
var
|
|
ms: TMemoryStream;
|
|
PCU, RestJSSrc, OrigJSSrc: string;
|
|
// restored classes:
|
|
RestResolver: TTestEnginePasResolver;
|
|
RestFileResolver: TFileResolver;
|
|
RestScanner: TPas2jsPasScanner;
|
|
RestParser: TPasParser;
|
|
RestConverter: TPasToJSConverter;
|
|
RestJSModule: TJSSourceElements;
|
|
begin
|
|
ConvertUnit;
|
|
|
|
FPCUWriter:=TPCUWriter.Create;
|
|
FPCUReader:=TPCUReader.Create;
|
|
ms:=TMemoryStream.Create;
|
|
RestParser:=nil;
|
|
RestScanner:=nil;
|
|
RestResolver:=nil;
|
|
RestFileResolver:=nil;
|
|
RestConverter:=nil;
|
|
RestJSModule:=nil;
|
|
try
|
|
try
|
|
PCUWriter.OnGetSrc:=@OnFilerGetSrc;
|
|
PCUWriter.OnIsElementUsed:=@OnConverterIsElementUsed;
|
|
PCUWriter.WritePCU(Engine,Converter,InitialFlags,ms,false);
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TCustomTestPrecompile.WriteReadUnit WRITE failed');
|
|
{$ENDIF}
|
|
Fail('Write failed('+E.ClassName+'): '+E.Message);
|
|
end;
|
|
end;
|
|
|
|
try
|
|
PCU:='';
|
|
SetLength(PCU,ms.Size);
|
|
System.Move(ms.Memory^,PCU[1],length(PCU));
|
|
|
|
writeln('TCustomTestPrecompile.WriteReadUnit PCU START-----');
|
|
writeln(PCU);
|
|
writeln('TCustomTestPrecompile.WriteReadUnit PCU END-------');
|
|
|
|
RestFileResolver:=TFileResolver.Create;
|
|
RestScanner:=TPas2jsPasScanner.Create(RestFileResolver);
|
|
InitScanner(RestScanner);
|
|
RestResolver:=TTestEnginePasResolver.Create;
|
|
RestResolver.Filename:=Engine.Filename;
|
|
RestResolver.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
|
|
RestResolver.OnFindUnit:=@OnRestResolverFindUnit;
|
|
RestParser:=TPasParser.Create(RestScanner,RestFileResolver,RestResolver);
|
|
RestParser.Options:=po_tcmodules;
|
|
RestResolver.CurrentParser:=RestParser;
|
|
ms.Position:=0;
|
|
PCUReader.ReadPCU(RestResolver,ms);
|
|
if not PCUReader.ReadContinue then
|
|
Fail('ReadContinue=false, pending used interfaces');
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TCustomTestPrecompile.WriteReadUnit READ failed');
|
|
{$ENDIF}
|
|
Fail('Read failed('+E.ClassName+'): '+E.Message);
|
|
end;
|
|
end;
|
|
|
|
// analyze
|
|
FRestAnalyzer:=TPas2JSAnalyzer.Create;
|
|
FRestAnalyzer.Resolver:=RestResolver;
|
|
try
|
|
RestAnalyzer.AnalyzeModule(RestResolver.RootElement);
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TCustomTestPrecompile.WriteReadUnit ANALYZEMODULE failed');
|
|
{$ENDIF}
|
|
Fail('AnalyzeModule precompiled failed('+E.ClassName+'): '+E.Message);
|
|
end;
|
|
end;
|
|
// check parser+resolver+analyzer
|
|
CheckRestoredResolver(Engine,RestResolver);
|
|
|
|
// convert using the precompiled procs
|
|
RestConverter:=CreateConverter;
|
|
RestConverter.Options:=Converter.Options;
|
|
RestConverter.OnIsElementUsed:=@OnRestConverterIsElementUsed;
|
|
RestConverter.OnIsTypeInfoUsed:=@OnRestConverterIsTypeInfoUsed;
|
|
try
|
|
RestJSModule:=RestConverter.ConvertPasElement(RestResolver.RootElement,RestResolver) as TJSSourceElements;
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
{$IFDEF VerbosePas2JS}
|
|
writeln('TCustomTestPrecompile.WriteReadUnit CONVERTER failed');
|
|
{$ENDIF}
|
|
Fail('Convert precompiled failed('+E.ClassName+'): '+E.Message);
|
|
end;
|
|
end;
|
|
|
|
OrigJSSrc:=JSToStr(JSModule);
|
|
RestJSSrc:=JSToStr(RestJSModule);
|
|
|
|
if OrigJSSrc<>RestJSSrc then
|
|
begin
|
|
writeln('TCustomTestPrecompile.WriteReadUnit OrigJSSrc:---------START');
|
|
writeln(OrigJSSrc);
|
|
writeln('TCustomTestPrecompile.WriteReadUnit OrigJSSrc:---------END');
|
|
writeln('TCustomTestPrecompile.WriteReadUnit RestJSSrc:---------START');
|
|
writeln(RestJSSrc);
|
|
writeln('TCustomTestPrecompile.WriteReadUnit RestJSSrc:---------END');
|
|
CheckDiff('WriteReadUnit JS diff',OrigJSSrc,RestJSSrc);
|
|
end;
|
|
|
|
finally
|
|
RestJSModule.Free;
|
|
RestConverter.Free;
|
|
FreeAndNil(FRestAnalyzer);
|
|
RestParser.Free;
|
|
RestScanner.Free;
|
|
if (RestResolver<>nil) and (RestResolver.RootElement<>nil) then
|
|
begin
|
|
RestResolver.RootElement.ReleaseUsedUnits;
|
|
RestResolver.RootElement.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
|
|
end;
|
|
RestResolver.Free; // free parser before resolver
|
|
RestFileResolver.Free;
|
|
|
|
ms.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.StartParsing;
|
|
begin
|
|
inherited StartParsing;
|
|
FInitialFlags.ParserOptions:=Parser.Options;
|
|
FInitialFlags.ModeSwitches:=Scanner.CurrentModeSwitches;
|
|
FInitialFlags.BoolSwitches:=Scanner.CurrentBoolSwitches;
|
|
FInitialFlags.ConverterOptions:=Converter.Options;
|
|
FInitialFlags.TargetPlatform:=Converter.Globals.TargetPlatform;
|
|
FInitialFlags.TargetProcessor:=Converter.Globals.TargetProcessor;
|
|
// ToDo: defines
|
|
end;
|
|
|
|
function TCustomTestPrecompile.CheckRestoredObject(const Path: string; Orig,
|
|
Rest: TObject): boolean;
|
|
begin
|
|
if Orig=nil then
|
|
begin
|
|
if Rest<>nil then
|
|
Fail(Path+': Orig=nil Rest='+GetObjName(Rest));
|
|
exit(false);
|
|
end
|
|
else if Rest=nil then
|
|
Fail(Path+': Orig='+GetObjName(Orig)+' Rest=nil');
|
|
if Orig.ClassType<>Rest.ClassType then
|
|
Fail(Path+': Orig='+GetObjName(Orig)+' Rest='+GetObjName(Rest));
|
|
Result:=true;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredJS(const Path, Orig, Rest: string);
|
|
var
|
|
OrigList, RestList: TStringList;
|
|
i: Integer;
|
|
begin
|
|
if Orig=Rest then exit;
|
|
writeln('TCustomTestPrecompile.CheckRestoredJS ORIG START--------------');
|
|
writeln(Orig);
|
|
writeln('TCustomTestPrecompile.CheckRestoredJS ORIG END----------------');
|
|
writeln('TCustomTestPrecompile.CheckRestoredJS REST START--------------');
|
|
writeln(Rest);
|
|
writeln('TCustomTestPrecompile.CheckRestoredJS REST END----------------');
|
|
OrigList:=TStringList.Create;
|
|
RestList:=TStringList.Create;
|
|
try
|
|
OrigList.Text:=Orig;
|
|
RestList.Text:=Rest;
|
|
for i:=0 to OrigList.Count-1 do
|
|
begin
|
|
if i>=RestList.Count then
|
|
Fail(Path+' missing: '+OrigList[i]);
|
|
writeln(' ',i,': '+OrigList[i]);
|
|
end;
|
|
if OrigList.Count<RestList.Count then
|
|
Fail(Path+' too much: '+RestList[OrigList.Count]);
|
|
finally
|
|
OrigList.Free;
|
|
RestList.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredResolver(Original,
|
|
Restored: TPas2JSResolver);
|
|
var
|
|
OrigParser, RestParser: TPasParser;
|
|
begin
|
|
AssertNotNull('CheckRestoredResolver Original',Original);
|
|
AssertNotNull('CheckRestoredResolver Restored',Restored);
|
|
if Original.ClassType<>Restored.ClassType then
|
|
Fail('CheckRestoredResolver Original='+Original.ClassName+' Restored='+Restored.ClassName);
|
|
CheckRestoredElement('RootElement',Original.RootElement,Restored.RootElement);
|
|
OrigParser:=Original.CurrentParser;
|
|
RestParser:=Restored.CurrentParser;
|
|
if OrigParser.Options<>RestParser.Options then
|
|
Fail('CheckRestoredResolver Parser.Options');
|
|
if OrigParser.Scanner.CurrentBoolSwitches<>RestParser.Scanner.CurrentBoolSwitches then
|
|
Fail('CheckRestoredResolver Scanner.BoolSwitches');
|
|
if OrigParser.Scanner.CurrentModeSwitches<>RestParser.Scanner.CurrentModeSwitches then
|
|
Fail('CheckRestoredResolver Scanner.ModeSwitches');
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredDeclarations(const Path: string;
|
|
Orig, Rest: TPasDeclarations);
|
|
var
|
|
i: Integer;
|
|
OrigDecl, RestDecl: TPasElement;
|
|
SubPath: String;
|
|
begin
|
|
for i:=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?';
|
|
CheckRestoredElement(SubPath,OrigDecl,RestDecl);
|
|
end;
|
|
AssertEquals(Path+'.Declarations.Count',Orig.Declarations.Count,Rest.Declarations.Count);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredSection(const Path: string; Orig,
|
|
Rest: TPasSection);
|
|
begin
|
|
if length(Orig.UsesClause)>0 then
|
|
; // ToDo
|
|
CheckRestoredDeclarations(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredModule(const Path: string; Orig,
|
|
Rest: TPasModule);
|
|
|
|
procedure CheckInitFinal(const Path: string; OrigBlock, RestBlock: TPasImplBlock);
|
|
begin
|
|
CheckRestoredObject(Path,OrigBlock,RestBlock);
|
|
if OrigBlock=nil then exit;
|
|
CheckRestoredCustomData(Path+'.CustomData',RestBlock,OrigBlock.CustomData,RestBlock.CustomData);
|
|
end;
|
|
|
|
begin
|
|
if not (Orig.CustomData is TPas2JSModuleScope) then
|
|
Fail(Path+'.CustomData is not TPasModuleScope'+GetObjName(Orig.CustomData));
|
|
|
|
CheckRestoredElement(Path+'.InterfaceSection',Orig.InterfaceSection,Rest.InterfaceSection);
|
|
CheckRestoredElement(Path+'.ImplementationSection',Orig.ImplementationSection,Rest.ImplementationSection);
|
|
if Orig is TPasProgram then
|
|
CheckRestoredElement(Path+'.ProgramSection',TPasProgram(Orig).ProgramSection,TPasProgram(Rest).ProgramSection)
|
|
else if Orig is TPasLibrary then
|
|
CheckRestoredElement(Path+'.LibrarySection',TPasLibrary(Orig).LibrarySection,TPasLibrary(Rest).LibrarySection);
|
|
|
|
CheckInitFinal(Path+'.InitializationSection',Orig.InitializationSection,Rest.InitializationSection);
|
|
CheckInitFinal(Path+'.FnializationSection',Orig.FinalizationSection,Rest.FinalizationSection);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredScopeReference(const Path: string;
|
|
Orig, Rest: TPasScope);
|
|
begin
|
|
if not CheckRestoredObject(Path,Orig,Rest) then exit;
|
|
CheckRestoredReference(Path+'.Element',Orig.Element,Rest.Element);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredElementBase(const Path: string;
|
|
Orig, Rest: TPasElementBase);
|
|
begin
|
|
CheckRestoredObject(Path+'.CustomData',Orig.CustomData,Rest.CustomData);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredResolveData(const Path: string;
|
|
Orig, Rest: TResolveData);
|
|
begin
|
|
CheckRestoredElementBase(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredPasScope(const Path: string; Orig,
|
|
Rest: TPasScope);
|
|
begin
|
|
CheckRestoredReference(Path+'.VisibilityContext',Orig.VisibilityContext,Rest.VisibilityContext);
|
|
CheckRestoredResolveData(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredModuleScope(const Path: string;
|
|
Orig, Rest: TPas2JSModuleScope);
|
|
begin
|
|
AssertEquals(Path+'.FirstName',Orig.FirstName,Rest.FirstName);
|
|
if Orig.Flags<>Rest.Flags then
|
|
Fail(Path+'.Flags');
|
|
if Orig.BoolSwitches<>Rest.BoolSwitches then
|
|
Fail(Path+'.BoolSwitches');
|
|
CheckRestoredReference(Path+'.AssertClass',Orig.AssertClass,Rest.AssertClass);
|
|
CheckRestoredReference(Path+'.AssertDefConstructor',Orig.AssertDefConstructor,Rest.AssertDefConstructor);
|
|
CheckRestoredReference(Path+'.AssertMsgConstructor',Orig.AssertMsgConstructor,Rest.AssertMsgConstructor);
|
|
CheckRestoredReference(Path+'.RangeErrorClass',Orig.RangeErrorClass,Rest.RangeErrorClass);
|
|
CheckRestoredReference(Path+'.RangeErrorConstructor',Orig.RangeErrorConstructor,Rest.RangeErrorConstructor);
|
|
CheckRestoredReference(Path+'.SystemTVarRec',Orig.SystemTVarRec,Rest.SystemTVarRec);
|
|
CheckRestoredReference(Path+'.SystemVarRecs',Orig.SystemVarRecs,Rest.SystemVarRecs);
|
|
CheckRestoredPasScope(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredIdentifierScope(
|
|
const Path: string; Orig, Rest: TPasIdentifierScope);
|
|
var
|
|
OrigList: TFPList;
|
|
i: Integer;
|
|
OrigIdentifier, RestIdentifier: TPasIdentifier;
|
|
begin
|
|
OrigList:=nil;
|
|
try
|
|
OrigList:=Orig.GetLocalIdentifiers;
|
|
for i:=0 to OrigList.Count-1 do
|
|
begin
|
|
OrigIdentifier:=TPasIdentifier(OrigList[i]);
|
|
RestIdentifier:=Rest.FindLocalIdentifier(OrigIdentifier.Identifier);
|
|
if RestIdentifier=nil then
|
|
Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Missing RestIdentifier Orig='+OrigIdentifier.Identifier);
|
|
repeat
|
|
AssertEquals(Path+'.Local.Identifier',OrigIdentifier.Identifier,RestIdentifier.Identifier);
|
|
CheckRestoredReference(Path+'.Local',OrigIdentifier.Element,RestIdentifier.Element);
|
|
if OrigIdentifier.Kind<>RestIdentifier.Kind then
|
|
Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Orig='+PCUIdentifierKindNames[OrigIdentifier.Kind]+' Rest='+PCUIdentifierKindNames[RestIdentifier.Kind]);
|
|
if OrigIdentifier.NextSameIdentifier=nil then
|
|
begin
|
|
if RestIdentifier.NextSameIdentifier<>nil then
|
|
Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Too many RestIdentifier.NextSameIdentifier='+GetObjName(RestIdentifier.Element));
|
|
break;
|
|
end
|
|
else begin
|
|
if RestIdentifier.NextSameIdentifier=nil then
|
|
Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Missing RestIdentifier.NextSameIdentifier Orig='+GetObjName(OrigIdentifier.NextSameIdentifier.Element));
|
|
end;
|
|
if CompareText(OrigIdentifier.Identifier,OrigIdentifier.NextSameIdentifier.Identifier)<>0 then
|
|
Fail(Path+'.Local['+OrigIdentifier.Identifier+'] Cur.Identifier<>Next.Identifier '+OrigIdentifier.Identifier+'<>'+OrigIdentifier.NextSameIdentifier.Identifier);
|
|
OrigIdentifier:=OrigIdentifier.NextSameIdentifier;
|
|
RestIdentifier:=RestIdentifier.NextSameIdentifier;
|
|
until false;
|
|
end;
|
|
finally
|
|
OrigList.Free;
|
|
end;
|
|
CheckRestoredPasScope(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredSectionScope(const Path: string;
|
|
Orig, Rest: TPas2JSSectionScope);
|
|
var
|
|
i: Integer;
|
|
OrigUses, RestUses: TPas2JSSectionScope;
|
|
OrigHelperEntry, RestHelperEntry: TPRHelperEntry;
|
|
begin
|
|
if Orig.BoolSwitches<>Rest.BoolSwitches then
|
|
Fail(Path+'.BoolSwitches Orig='+BoolSwitchesToStr(Orig.BoolSwitches)+' Rest='+BoolSwitchesToStr(Rest.BoolSwitches));
|
|
if Orig.ModeSwitches<>Rest.ModeSwitches then
|
|
Fail(Path+'.ModeSwitches');
|
|
AssertEquals(Path+' UsesScopes.Count',Orig.UsesScopes.Count,Rest.UsesScopes.Count);
|
|
for i:=0 to Orig.UsesScopes.Count-1 do
|
|
begin
|
|
OrigUses:=TPas2JSSectionScope(Orig.UsesScopes[i]);
|
|
if not (TObject(Rest.UsesScopes[i]) is TPas2JSSectionScope) then
|
|
Fail(Path+'.UsesScopes['+IntToStr(i)+'] Rest='+GetObjName(TObject(Rest.UsesScopes[i])));
|
|
RestUses:=TPas2JSSectionScope(Rest.UsesScopes[i]);
|
|
if OrigUses.ClassType<>RestUses.ClassType then
|
|
Fail(Path+'.UsesScopes['+IntToStr(i)+'] Orig='+GetObjName(OrigUses)+' Rest='+GetObjName(RestUses));
|
|
CheckRestoredReference(Path+'.UsesScopes['+IntToStr(i)+']',OrigUses.Element,RestUses.Element);
|
|
end;
|
|
AssertEquals(Path+' length(Helpers)',length(Orig.Helpers),length(Rest.Helpers));
|
|
for i:=0 to length(Orig.Helpers)-1 do
|
|
begin
|
|
OrigHelperEntry:=TPRHelperEntry(Orig.Helpers[i]);
|
|
RestHelperEntry:=TPRHelperEntry(Rest.Helpers[i]);
|
|
if OrigHelperEntry.ClassType<>RestHelperEntry.ClassType then
|
|
Fail(Path+'.Helpers['+IntToStr(i)+'] Orig='+GetObjName(OrigHelperEntry)+' Rest='+GetObjName(RestHelperEntry));
|
|
AssertEquals(Path+'.Helpers['+IntToStr(i)+'].Added',OrigHelperEntry.Added,RestHelperEntry.Added);
|
|
CheckRestoredReference(Path+'.Helpers['+IntToStr(i)+'].Helper',OrigHelperEntry.Helper,RestHelperEntry.Helper);
|
|
CheckRestoredReference(Path+'.Helpers['+IntToStr(i)+'].HelperForType',OrigHelperEntry.HelperForType,RestHelperEntry.HelperForType);
|
|
end;
|
|
|
|
AssertEquals(Path+'.Finished',Orig.Finished,Rest.Finished);
|
|
CheckRestoredIdentifierScope(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredInitialFinalizationScope(
|
|
const Path: string; Orig, Rest: TPas2JSInitialFinalizationScope);
|
|
begin
|
|
CheckRestoredScopeRefs(Path+'.References',Orig.References,Rest.References);
|
|
if Orig.JS<>Rest.JS then
|
|
CheckRestoredJS(Path+'.JS',Orig.JS,Rest.JS);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredEnumTypeScope(const Path: string;
|
|
Orig, Rest: TPasEnumTypeScope);
|
|
begin
|
|
CheckRestoredReference(Path+'.CanonicalSet',Orig.CanonicalSet,Rest.CanonicalSet);
|
|
CheckRestoredIdentifierScope(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredRecordScope(const Path: string;
|
|
Orig, Rest: TPasRecordScope);
|
|
begin
|
|
CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
|
|
CheckRestoredIdentifierScope(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredClassScope(const Path: string;
|
|
Orig, Rest: TPas2JSClassScope);
|
|
var
|
|
i, j: Integer;
|
|
OrigObj, RestObj: TObject;
|
|
OrigMap, RestMap: TPasClassIntfMap;
|
|
SubPath: String;
|
|
begin
|
|
CheckRestoredScopeReference(Path+'.AncestorScope',Orig.AncestorScope,Rest.AncestorScope);
|
|
CheckRestoredElement(Path+'.CanonicalClassOf',Orig.CanonicalClassOf,Rest.CanonicalClassOf);
|
|
CheckRestoredReference(Path+'.DirectAncestor',Orig.DirectAncestor,Rest.DirectAncestor);
|
|
CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
|
|
if Orig.Flags<>Rest.Flags then
|
|
Fail(Path+'.Flags');
|
|
AssertEquals(Path+'.AbstractProcs.length',length(Orig.AbstractProcs),length(Rest.AbstractProcs));
|
|
for i:=0 to length(Orig.AbstractProcs)-1 do
|
|
CheckRestoredReference(Path+'.AbstractProcs['+IntToStr(i)+']',Orig.AbstractProcs[i],Rest.AbstractProcs[i]);
|
|
|
|
CheckRestoredReference(Path+'.NewInstanceFunction',Orig.NewInstanceFunction,Rest.NewInstanceFunction);
|
|
AssertEquals(Path+'.GUID',Orig.GUID,Rest.GUID);
|
|
AssertEquals(Path+'.DispatchField',Orig.DispatchField,Rest.DispatchField);
|
|
AssertEquals(Path+'.DispatchStrField',Orig.DispatchStrField,Rest.DispatchStrField);
|
|
|
|
CheckRestoredObject('.Interfaces',Orig.Interfaces,Rest.Interfaces);
|
|
if Orig.Interfaces<>nil then
|
|
begin
|
|
AssertEquals(Path+'.Interfaces.Count',Orig.Interfaces.Count,Rest.Interfaces.Count);
|
|
for i:=0 to Orig.Interfaces.Count-1 do
|
|
begin
|
|
SubPath:=Path+'.Interfaces['+IntToStr(i)+']';
|
|
OrigObj:=TObject(Orig.Interfaces[i]);
|
|
RestObj:=TObject(Rest.Interfaces[i]);
|
|
CheckRestoredObject(SubPath,OrigObj,RestObj);
|
|
if OrigObj is TPasProperty then
|
|
CheckRestoredReference(SubPath+'(TPasProperty)',
|
|
TPasProperty(OrigObj),TPasProperty(RestObj))
|
|
else if OrigObj is TPasClassIntfMap then
|
|
begin
|
|
OrigMap:=TPasClassIntfMap(OrigObj);
|
|
RestMap:=TPasClassIntfMap(RestObj);
|
|
repeat
|
|
AssertNotNull(SubPath+'.Intf Orig',OrigMap.Intf);
|
|
CheckRestoredObject(SubPath+'.Intf',OrigMap.Intf,RestMap.Intf);
|
|
SubPath:=SubPath+'.Map('+OrigMap.Intf.Name+')';
|
|
CheckRestoredObject(SubPath+'.Element',OrigMap.Element,RestMap.Element);
|
|
CheckRestoredObject(SubPath+'.Procs',OrigMap.Procs,RestMap.Procs);
|
|
if OrigMap.Procs=nil then
|
|
begin
|
|
if OrigMap.Intf.Members.Count>0 then
|
|
Fail(SubPath+' expected '+IntToStr(OrigMap.Intf.Members.Count)+' procs, but Procs=nil');
|
|
end
|
|
else
|
|
for j:=0 to OrigMap.Procs.Count-1 do
|
|
begin
|
|
OrigObj:=TObject(OrigMap.Procs[j]);
|
|
RestObj:=TObject(RestMap.Procs[j]);
|
|
CheckRestoredReference(SubPath+'.Procs['+IntToStr(j)+']',TPasElement(OrigObj),TPasElement(RestObj));
|
|
end;
|
|
AssertEquals(Path+'.Procs.Count',OrigMap.Procs.Count,RestMap.Procs.Count);
|
|
|
|
CheckRestoredObject(SubPath+'.AncestorMap',OrigMap.AncestorMap,RestMap.AncestorMap);
|
|
OrigMap:=OrigMap.AncestorMap;
|
|
RestMap:=RestMap.AncestorMap;
|
|
until OrigMap=nil;
|
|
end
|
|
else
|
|
Fail(SubPath+' unknown class '+GetObjName(OrigObj));
|
|
end;
|
|
end;
|
|
|
|
CheckRestoredIdentifierScope(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredProcScope(const Path: string;
|
|
Orig, Rest: TPas2JSProcedureScope);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
CheckRestoredReference(Path+'.DeclarationProc',Orig.DeclarationProc,Rest.DeclarationProc);
|
|
CheckRestoredReference(Path+'.ImplProc',Orig.ImplProc,Rest.ImplProc);
|
|
CheckRestoredScopeRefs(Path+'.References',Orig.References,Rest.References);
|
|
if Orig.BodyJS<>Rest.BodyJS then
|
|
CheckRestoredJS(Path+'.BodyJS',Orig.BodyJS,Rest.BodyJS);
|
|
|
|
CheckRestoredObject(Path+'.GlobalJS',Orig.GlobalJS,Rest.GlobalJS);
|
|
if Orig.GlobalJS<>nil then
|
|
begin
|
|
for i:=0 to Orig.GlobalJS.Count-1 do
|
|
begin
|
|
if i>=Rest.GlobalJS.Count then
|
|
Fail(Path+'.GlobalJS['+IntToStr(i)+'] missing: '+Orig.GlobalJS[i]);
|
|
CheckRestoredJS(Path+'.GlobalJS['+IntToStr(i)+']',Orig.GlobalJS[i],Rest.GlobalJS[i]);
|
|
end;
|
|
if Orig.GlobalJS.Count<Rest.GlobalJS.Count then
|
|
Fail(Path+'.GlobalJS['+IntToStr(i)+'] too much: '+Rest.GlobalJS[Orig.GlobalJS.Count]);
|
|
end;
|
|
|
|
if Rest.DeclarationProc=nil then
|
|
begin
|
|
AssertEquals(Path+'.ResultVarName',Orig.ResultVarName,Rest.ResultVarName);
|
|
CheckRestoredReference(Path+'.OverriddenProc',Orig.OverriddenProc,Rest.OverriddenProc);
|
|
|
|
CheckRestoredScopeReference(Path+'.ClassScope',Orig.ClassRecScope,Rest.ClassRecScope);
|
|
CheckRestoredElement(Path+'.SelfArg',Orig.SelfArg,Rest.SelfArg);
|
|
if Orig.Flags<>Rest.Flags then
|
|
Fail(Path+'.Flags');
|
|
if Orig.BoolSwitches<>Rest.BoolSwitches then
|
|
Fail(Path+'.BoolSwitches');
|
|
if Orig.ModeSwitches<>Rest.ModeSwitches then
|
|
Fail(Path+'.ModeSwitches');
|
|
|
|
//CheckRestoredIdentifierScope(Path,Orig,Rest);
|
|
end
|
|
else
|
|
begin
|
|
// ImplProc
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredScopeRefs(const Path: string;
|
|
Orig, Rest: TPasScopeReferences);
|
|
var
|
|
OrigList, RestList: TFPList;
|
|
i: Integer;
|
|
OrigRef, RestRef: TPasScopeReference;
|
|
begin
|
|
CheckRestoredObject(Path,Orig,Rest);
|
|
if Orig=nil then exit;
|
|
OrigList:=nil;
|
|
RestList:=nil;
|
|
try
|
|
OrigList:=Orig.GetList;
|
|
RestList:=Rest.GetList;
|
|
OrigList.Sort(@CompareListOfProcScopeRef);
|
|
RestList.Sort(@CompareListOfProcScopeRef);
|
|
for i:=0 to OrigList.Count-1 do
|
|
begin
|
|
OrigRef:=TPasScopeReference(OrigList[i]);
|
|
if i>=RestList.Count then
|
|
Fail(Path+'['+IntToStr(i)+'] Missing in Rest: "'+OrigRef.Element.Name+'"');
|
|
RestRef:=TPasScopeReference(RestList[i]);
|
|
CheckRestoredReference(Path+'['+IntToStr(i)+'].Name="'+OrigRef.Element.Name+'"',OrigRef.Element,RestRef.Element);
|
|
if OrigRef.Access<>RestRef.Access then
|
|
AssertEquals(Path+'['+IntToStr(i)+']"'+OrigRef.Element.Name+'".Access',
|
|
PCUPSRefAccessNames[OrigRef.Access],PCUPSRefAccessNames[RestRef.Access]);
|
|
end;
|
|
if RestList.Count>OrigList.Count then
|
|
begin
|
|
i:=OrigList.Count;
|
|
RestRef:=TPasScopeReference(RestList[i]);
|
|
Fail(Path+'['+IntToStr(i)+'] Too many in Rest: "'+RestRef.Element.Name+'"');
|
|
end;
|
|
finally
|
|
OrigList.Free;
|
|
RestList.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredPropertyScope(const Path: string;
|
|
Orig, Rest: TPasPropertyScope);
|
|
begin
|
|
CheckRestoredReference(Path+'.AncestorProp',Orig.AncestorProp,Rest.AncestorProp);
|
|
CheckRestoredIdentifierScope(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredResolvedReference(
|
|
const Path: string; Orig, Rest: TResolvedReference);
|
|
var
|
|
C: TClass;
|
|
begin
|
|
if Orig.Flags<>Rest.Flags then
|
|
Fail(Path+'.Flags');
|
|
if Orig.Access<>Rest.Access then
|
|
AssertEquals(Path+'.Access',PCUResolvedRefAccessNames[Orig.Access],PCUResolvedRefAccessNames[Rest.Access]);
|
|
if not CheckRestoredObject(Path+'.Context',Orig.Context,Rest.Context) then exit;
|
|
if Orig.Context<>nil then
|
|
begin
|
|
C:=Orig.Context.ClassType;
|
|
if C=TResolvedRefCtxConstructor then
|
|
CheckRestoredReference(Path+'.Context[TResolvedRefCtxConstructor].Typ',
|
|
TResolvedRefCtxConstructor(Orig.Context).Typ,
|
|
TResolvedRefCtxConstructor(Rest.Context).Typ);
|
|
end;
|
|
CheckRestoredScopeReference(Path+'.WithExprScope',Orig.WithExprScope,Rest.WithExprScope);
|
|
CheckRestoredReference(Path+'.Declaration',Orig.Declaration,Rest.Declaration);
|
|
|
|
CheckRestoredResolveData(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredEvalValue(const Path: string;
|
|
Orig, Rest: TResEvalValue);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if not CheckRestoredObject(Path,Orig,Rest) then exit;
|
|
if Orig.Kind<>Rest.Kind then
|
|
Fail(Path+'.Kind');
|
|
if not CheckRestoredObject(Path+'.Element',Orig.Element,Rest.Element) then exit;
|
|
CheckRestoredReference(Path+'.IdentEl',Orig.IdentEl,Rest.IdentEl);
|
|
case Orig.Kind of
|
|
revkNone: Fail(Path+'.Kind=revkNone');
|
|
revkCustom: Fail(Path+'.Kind=revkNone');
|
|
revkNil: ;
|
|
revkBool: AssertEquals(Path+'.B',TResEvalBool(Orig).B,TResEvalBool(Rest).B);
|
|
revkInt: AssertEquals(Path+'.Int',TResEvalInt(Orig).Int,TResEvalInt(Rest).Int);
|
|
revkUInt:
|
|
if TResEvalUInt(Orig).UInt<>TResEvalUInt(Rest).UInt then
|
|
Fail(Path+'.UInt');
|
|
revkFloat: AssertEquals(Path+'.FloatValue',TResEvalFloat(Orig).FloatValue,TResEvalFloat(Rest).FloatValue);
|
|
revkString: AssertEquals(Path+'.S,Raw',TResEvalString(Orig).S,TResEvalString(Rest).S);
|
|
revkUnicodeString: AssertEquals(Path+'.S,UTF16',String(TResEvalUTF16(Orig).S),String(TResEvalUTF16(Rest).S));
|
|
revkEnum:
|
|
begin
|
|
AssertEquals(Path+'.Index',TResEvalEnum(Orig).Index,TResEvalEnum(Rest).Index);
|
|
CheckRestoredReference(Path+'.ElType',TResEvalEnum(Orig).ElType,TResEvalEnum(Rest).ElType);
|
|
end;
|
|
revkRangeInt:
|
|
begin
|
|
if TResEvalRangeInt(Orig).ElKind<>TResEvalRangeInt(Rest).ElKind then
|
|
Fail(Path+'.Int/ElKind');
|
|
CheckRestoredReference(Path+'.Int/ElType',TResEvalRangeInt(Orig).ElType,TResEvalRangeInt(Rest).ElType);
|
|
AssertEquals(Path+'.Int/RangeStart',TResEvalRangeInt(Orig).RangeStart,TResEvalRangeInt(Rest).RangeStart);
|
|
AssertEquals(Path+'.Int/RangeEnd',TResEvalRangeInt(Orig).RangeEnd,TResEvalRangeInt(Rest).RangeEnd);
|
|
end;
|
|
revkRangeUInt:
|
|
begin
|
|
if TResEvalRangeUInt(Orig).RangeStart<>TResEvalRangeUInt(Rest).RangeStart then
|
|
Fail(Path+'.UInt/RangeStart');
|
|
if TResEvalRangeUInt(Orig).RangeEnd<>TResEvalRangeUInt(Rest).RangeEnd then
|
|
Fail(Path+'.UInt/RangeEnd');
|
|
end;
|
|
revkSetOfInt:
|
|
begin
|
|
if TResEvalSet(Orig).ElKind<>TResEvalSet(Rest).ElKind then
|
|
Fail(Path+'.SetInt/ElKind');
|
|
CheckRestoredReference(Path+'.SetInt/ElType',TResEvalSet(Orig).ElType,TResEvalSet(Rest).ElType);
|
|
AssertEquals(Path+'.SetInt/RangeStart',TResEvalSet(Orig).RangeStart,TResEvalSet(Rest).RangeStart);
|
|
AssertEquals(Path+'.SetInt/RangeEnd',TResEvalSet(Orig).RangeEnd,TResEvalSet(Rest).RangeEnd);
|
|
AssertEquals(Path+'.SetInt/length(Items)',length(TResEvalSet(Orig).Ranges),length(TResEvalSet(Rest).Ranges));
|
|
for i:=0 to length(TResEvalSet(Orig).Ranges)-1 do
|
|
begin
|
|
AssertEquals(Path+'.SetInt/Items['+IntToStr(i)+'].RangeStart',
|
|
TResEvalSet(Orig).Ranges[i].RangeStart,TResEvalSet(Rest).Ranges[i].RangeStart);
|
|
AssertEquals(Path+'.SetInt/Items['+IntToStr(i)+'].RangeEnd',
|
|
TResEvalSet(Orig).Ranges[i].RangeEnd,TResEvalSet(Rest).Ranges[i].RangeEnd);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredCustomData(const Path: string;
|
|
RestoredEl: TPasElement; Orig, Rest: TObject);
|
|
var
|
|
C: TClass;
|
|
begin
|
|
if not CheckRestoredObject(Path,Orig,Rest) then exit;
|
|
|
|
C:=Orig.ClassType;
|
|
if C=TResolvedReference then
|
|
CheckRestoredResolvedReference(Path+'[TResolvedReference]',TResolvedReference(Orig),TResolvedReference(Rest))
|
|
else if C=TPas2JSModuleScope then
|
|
CheckRestoredModuleScope(Path+'[TPas2JSModuleScope]',TPas2JSModuleScope(Orig),TPas2JSModuleScope(Rest))
|
|
else if C=TPas2JSSectionScope then
|
|
CheckRestoredSectionScope(Path+'[TPas2JSSectionScope]',TPas2JSSectionScope(Orig),TPas2JSSectionScope(Rest))
|
|
else if C=TPas2JSInitialFinalizationScope then
|
|
CheckRestoredInitialFinalizationScope(Path+'[TPas2JSInitialFinalizationScope]',TPas2JSInitialFinalizationScope(Orig),TPas2JSInitialFinalizationScope(Rest))
|
|
else if C=TPasEnumTypeScope then
|
|
CheckRestoredEnumTypeScope(Path+'[TPasEnumTypeScope]',TPasEnumTypeScope(Orig),TPasEnumTypeScope(Rest))
|
|
else if C=TPasRecordScope then
|
|
CheckRestoredRecordScope(Path+'[TPasRecordScope]',TPasRecordScope(Orig),TPasRecordScope(Rest))
|
|
else if C=TPas2JSClassScope then
|
|
CheckRestoredClassScope(Path+'[TPas2JSClassScope]',TPas2JSClassScope(Orig),TPas2JSClassScope(Rest))
|
|
else if C=TPas2JSProcedureScope then
|
|
CheckRestoredProcScope(Path+'[TPas2JSProcedureScope]',TPas2JSProcedureScope(Orig),TPas2JSProcedureScope(Rest))
|
|
else if C=TPasPropertyScope then
|
|
CheckRestoredPropertyScope(Path+'[TPasPropertyScope]',TPasPropertyScope(Orig),TPasPropertyScope(Rest))
|
|
else if C.InheritsFrom(TResEvalValue) then
|
|
CheckRestoredEvalValue(Path+'['+Orig.ClassName+']',TResEvalValue(Orig),TResEvalValue(Rest))
|
|
else
|
|
Fail(Path+': unknown CustomData "'+GetObjName(Orig)+'" El='+GetObjName(RestoredEl));
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredReference(const Path: string;
|
|
Orig, Rest: TPasElement);
|
|
begin
|
|
if not CheckRestoredObject(Path,Orig,Rest) then exit;
|
|
AssertEquals(Path+'.Name',Orig.Name,Rest.Name);
|
|
|
|
if Orig is TPasUnresolvedSymbolRef then
|
|
exit; // compiler types and procs are the same in every unit -> skip checking unit
|
|
|
|
CheckRestoredReference(Path+'.Parent',Orig.Parent,Rest.Parent);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredElOrRef(const Path: string; Orig,
|
|
OrigProp, Rest, RestProp: TPasElement);
|
|
begin
|
|
if not CheckRestoredObject(Path,OrigProp,RestProp) then exit;
|
|
if Orig<>OrigProp.Parent then
|
|
begin
|
|
if Rest=RestProp.Parent then
|
|
Fail(Path+' Orig "'+GetObjName(OrigProp)+'" is reference Orig.Parent='+GetObjName(Orig)+', Rest "'+GetObjName(RestProp)+'" is insitu');
|
|
CheckRestoredReference(Path,OrigProp,RestProp);
|
|
end
|
|
else
|
|
CheckRestoredElement(Path,OrigProp,RestProp);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredAnalyzerElement(
|
|
const Path: string; Orig, Rest: TPasElement);
|
|
var
|
|
OrigUsed, RestUsed: TPAElement;
|
|
begin
|
|
//writeln('TCustomTestPrecompile.CheckRestoredAnalyzerElement ',GetObjName(RestAnalyzer));
|
|
if RestAnalyzer=nil then exit;
|
|
if Orig.ClassType=TPasArgument then exit;
|
|
OrigUsed:=Analyzer.FindUsedElement(Orig);
|
|
//writeln('TCustomTestPrecompile.CheckRestoredAnalyzerElement ',GetObjName(Orig),'=',OrigUsed<>nil,' ',GetObjName(Rest),'=',RestAnalyzer.FindUsedElement(Rest)<>nil);
|
|
if OrigUsed<>nil then
|
|
begin
|
|
RestUsed:=RestAnalyzer.FindUsedElement(Rest);
|
|
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));
|
|
end
|
|
else if RestAnalyzer.IsUsed(Rest) then
|
|
begin
|
|
Fail(Path+': not used in OrigAnalyzer, but used in RestAnalyzer');
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredElement(const Path: string; Orig,
|
|
Rest: TPasElement);
|
|
var
|
|
C: TClass;
|
|
AModule: TPasModule;
|
|
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));
|
|
|
|
AModule:=Orig.GetModule;
|
|
if AModule<>Module then
|
|
Fail(Path+' wrong module: Orig='+GetObjName(AModule)+' '+GetObjName(Module));
|
|
|
|
AssertEquals(Path+'.Name',Orig.Name,Rest.Name);
|
|
AssertEquals(Path+'.SourceFilename',Orig.SourceFilename,Rest.SourceFilename);
|
|
AssertEquals(Path+'.SourceLinenumber',Orig.SourceLinenumber,Rest.SourceLinenumber);
|
|
//AssertEquals(Path+'.SourceEndLinenumber',Orig.SourceEndLinenumber,Rest.SourceEndLinenumber);
|
|
if Orig.Visibility<>Rest.Visibility then
|
|
Fail(Path+'.Visibility '+PCUMemberVisibilityNames[Orig.Visibility]+' '+PCUMemberVisibilityNames[Rest.Visibility]);
|
|
if Orig.Hints<>Rest.Hints then
|
|
Fail(Path+'.Hints');
|
|
AssertEquals(Path+'.HintMessage',Orig.HintMessage,Rest.HintMessage);
|
|
|
|
//writeln('TCustomTestPrecompile.CheckRestoredElement Checking Parent... Orig=',GetObjName(Orig),' Rest=',GetObjName(Rest));
|
|
CheckRestoredReference(Path+'.Parent',Orig.Parent,Rest.Parent);
|
|
|
|
//writeln('TCustomTestPrecompile.CheckRestoredElement Checking CustomData... Orig=',GetObjName(Orig),' Rest=',GetObjName(Rest));
|
|
CheckRestoredCustomData(Path+'.CustomData',Rest,Orig.CustomData,Rest.CustomData);
|
|
|
|
C:=Orig.ClassType;
|
|
if C=TUnaryExpr then
|
|
CheckRestoredUnaryExpr(Path,TUnaryExpr(Orig),TUnaryExpr(Rest))
|
|
else if C=TBinaryExpr then
|
|
CheckRestoredBinaryExpr(Path,TBinaryExpr(Orig),TBinaryExpr(Rest))
|
|
else if C=TPrimitiveExpr then
|
|
CheckRestoredPrimitiveExpr(Path,TPrimitiveExpr(Orig),TPrimitiveExpr(Rest))
|
|
else if C=TBoolConstExpr then
|
|
CheckRestoredBoolConstExpr(Path,TBoolConstExpr(Orig),TBoolConstExpr(Rest))
|
|
else if (C=TNilExpr)
|
|
or (C=TInheritedExpr)
|
|
or (C=TSelfExpr) then
|
|
CheckRestoredPasExpr(Path,TPasExpr(Orig),TPasExpr(Rest))
|
|
else if C=TParamsExpr then
|
|
CheckRestoredParamsExpr(Path,TParamsExpr(Orig),TParamsExpr(Rest))
|
|
else if C=TProcedureExpr then
|
|
CheckRestoredProcedureExpr(Path,TProcedureExpr(Orig),TProcedureExpr(Rest))
|
|
else if C=TRecordValues then
|
|
CheckRestoredRecordValues(Path,TRecordValues(Orig),TRecordValues(Rest))
|
|
else if C=TArrayValues then
|
|
CheckRestoredArrayValues(Path,TArrayValues(Orig),TArrayValues(Rest))
|
|
// TPasDeclarations is a base class
|
|
// TPasUsesUnit is checked in usesclause
|
|
// TPasSection is a base class
|
|
else if C=TPasResString then
|
|
CheckRestoredResString(Path,TPasResString(Orig),TPasResString(Rest))
|
|
// TPasType is a base clas
|
|
else if (C=TPasAliasType)
|
|
or (C=TPasTypeAliasType)
|
|
or (C=TPasClassOfType) then
|
|
CheckRestoredAliasType(Path,TPasAliasType(Orig),TPasAliasType(Rest))
|
|
else if C=TPasPointerType then
|
|
CheckRestoredPointerType(Path,TPasPointerType(Orig),TPasPointerType(Rest))
|
|
else if C=TPasSpecializeType then
|
|
CheckRestoredSpecializedType(Path,TPasSpecializeType(Orig),TPasSpecializeType(Rest))
|
|
else if C=TInlineSpecializeExpr then
|
|
CheckRestoredInlineSpecializedExpr(Path,TInlineSpecializeExpr(Orig),TInlineSpecializeExpr(Rest))
|
|
else if C=TPasRangeType then
|
|
CheckRestoredRangeType(Path,TPasRangeType(Orig),TPasRangeType(Rest))
|
|
else if C=TPasArrayType then
|
|
CheckRestoredArrayType(Path,TPasArrayType(Orig),TPasArrayType(Rest))
|
|
else if C=TPasFileType then
|
|
CheckRestoredFileType(Path,TPasFileType(Orig),TPasFileType(Rest))
|
|
else if C=TPasEnumValue then
|
|
CheckRestoredEnumValue(Path,TPasEnumValue(Orig),TPasEnumValue(Rest))
|
|
else if C=TPasEnumType then
|
|
CheckRestoredEnumType(Path,TPasEnumType(Orig),TPasEnumType(Rest))
|
|
else if C=TPasSetType then
|
|
CheckRestoredSetType(Path,TPasSetType(Orig),TPasSetType(Rest))
|
|
else if C=TPasVariant then
|
|
CheckRestoredVariant(Path,TPasVariant(Orig),TPasVariant(Rest))
|
|
else if C=TPasRecordType then
|
|
CheckRestoredRecordType(Path,TPasRecordType(Orig),TPasRecordType(Rest))
|
|
else if C=TPasClassType then
|
|
CheckRestoredClassType(Path,TPasClassType(Orig),TPasClassType(Rest))
|
|
else if C=TPasArgument then
|
|
CheckRestoredArgument(Path,TPasArgument(Orig),TPasArgument(Rest))
|
|
else if C=TPasProcedureType then
|
|
CheckRestoredProcedureType(Path,TPasProcedureType(Orig),TPasProcedureType(Rest))
|
|
else if C=TPasResultElement then
|
|
CheckRestoredResultElement(Path,TPasResultElement(Orig),TPasResultElement(Rest))
|
|
else if C=TPasFunctionType then
|
|
CheckRestoredFunctionType(Path,TPasFunctionType(Orig),TPasFunctionType(Rest))
|
|
else if C=TPasStringType then
|
|
CheckRestoredStringType(Path,TPasStringType(Orig),TPasStringType(Rest))
|
|
else if C=TPasVariable then
|
|
CheckRestoredVariable(Path,TPasVariable(Orig),TPasVariable(Rest))
|
|
else if C=TPasExportSymbol then
|
|
CheckRestoredExportSymbol(Path,TPasExportSymbol(Orig),TPasExportSymbol(Rest))
|
|
else if C=TPasConst then
|
|
CheckRestoredConst(Path,TPasConst(Orig),TPasConst(Rest))
|
|
else if C=TPasProperty then
|
|
CheckRestoredProperty(Path,TPasProperty(Orig),TPasProperty(Rest))
|
|
else if C=TPasMethodResolution then
|
|
CheckRestoredMethodResolution(Path,TPasMethodResolution(Orig),TPasMethodResolution(Rest))
|
|
else if (C=TPasProcedure)
|
|
or (C=TPasFunction)
|
|
or (C=TPasConstructor)
|
|
or (C=TPasClassConstructor)
|
|
or (C=TPasDestructor)
|
|
or (C=TPasClassDestructor)
|
|
or (C=TPasClassProcedure)
|
|
or (C=TPasClassFunction)
|
|
then
|
|
CheckRestoredProcedure(Path,TPasProcedure(Orig),TPasProcedure(Rest))
|
|
else if (C=TPasOperator)
|
|
or (C=TPasClassOperator) then
|
|
CheckRestoredOperator(Path,TPasOperator(Orig),TPasOperator(Rest))
|
|
else if (C=TPasModule)
|
|
or (C=TPasProgram)
|
|
or (C=TPasLibrary) then
|
|
CheckRestoredModule(Path,TPasModule(Orig),TPasModule(Rest))
|
|
else if C.InheritsFrom(TPasSection) then
|
|
CheckRestoredSection(Path,TPasSection(Orig),TPasSection(Rest))
|
|
else if C=TPasAttributes then
|
|
CheckRestoredAttributes(Path,TPasAttributes(Orig),TPasAttributes(Rest))
|
|
else
|
|
Fail(Path+': unknown class '+C.ClassName);
|
|
|
|
CheckRestoredAnalyzerElement(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredElementList(const Path: string;
|
|
Orig, Rest: TFPList);
|
|
var
|
|
OrigItem, RestItem: TObject;
|
|
i: Integer;
|
|
SubPath: String;
|
|
begin
|
|
if not CheckRestoredObject(Path,Orig,Rest) then exit;
|
|
AssertEquals(Path+'.Count',Orig.Count,Rest.Count);
|
|
for i:=0 to Orig.Count-1 do
|
|
begin
|
|
SubPath:=Path+'['+IntToStr(i)+']';
|
|
OrigItem:=TObject(Orig[i]);
|
|
if not (OrigItem is TPasElement) then
|
|
Fail(SubPath+' Orig='+GetObjName(OrigItem));
|
|
RestItem:=TObject(Rest[i]);
|
|
if not (RestItem is TPasElement) then
|
|
Fail(SubPath+' Rest='+GetObjName(RestItem));
|
|
//writeln('TCustomTestPrecompile.CheckRestoredElementList ',GetObjName(OrigItem),' ',GetObjName(RestItem));
|
|
SubPath:=Path+'['+IntToStr(i)+']"'+TPasElement(OrigItem).Name+'"';
|
|
CheckRestoredElement(SubPath,TPasElement(OrigItem),TPasElement(RestItem));
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredElRefList(const Path: string;
|
|
OrigParent: TPasElement; Orig: TFPList; RestParent: TPasElement;
|
|
Rest: TFPList; AllowInSitu: boolean);
|
|
var
|
|
OrigItem, RestItem: TObject;
|
|
i: Integer;
|
|
SubPath: String;
|
|
begin
|
|
if not CheckRestoredObject(Path,Orig,Rest) then exit;
|
|
AssertEquals(Path+'.Count',Orig.Count,Rest.Count);
|
|
for i:=0 to Orig.Count-1 do
|
|
begin
|
|
SubPath:=Path+'['+IntToStr(i)+']';
|
|
OrigItem:=TObject(Orig[i]);
|
|
if not (OrigItem is TPasElement) then
|
|
Fail(SubPath+' Orig='+GetObjName(OrigItem));
|
|
RestItem:=TObject(Rest[i]);
|
|
if not (RestItem is TPasElement) then
|
|
Fail(SubPath+' Rest='+GetObjName(RestItem));
|
|
if AllowInSitu then
|
|
CheckRestoredElOrRef(SubPath,OrigParent,TPasElement(OrigItem),RestParent,TPasElement(RestItem))
|
|
else
|
|
CheckRestoredReference(SubPath,TPasElement(OrigItem),TPasElement(RestItem));
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredPasExpr(const Path: string; Orig,
|
|
Rest: TPasExpr);
|
|
begin
|
|
if Orig.Kind<>Rest.Kind then
|
|
Fail(Path+'.Kind');
|
|
if Orig.OpCode<>Rest.OpCode then
|
|
Fail(Path+'.OpCode');
|
|
CheckRestoredElement(Path+'.Format1',Orig.format1,Rest.format1);
|
|
CheckRestoredElement(Path+'.Format2',Orig.format2,Rest.format2);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredUnaryExpr(const Path: string;
|
|
Orig, Rest: TUnaryExpr);
|
|
begin
|
|
CheckRestoredElement(Path+'.Operand',Orig.Operand,Rest.Operand);
|
|
CheckRestoredPasExpr(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredBinaryExpr(const Path: string;
|
|
Orig, Rest: TBinaryExpr);
|
|
begin
|
|
CheckRestoredElement(Path+'.left',Orig.left,Rest.left);
|
|
CheckRestoredElement(Path+'.right',Orig.right,Rest.right);
|
|
CheckRestoredPasExpr(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredPrimitiveExpr(const Path: string;
|
|
Orig, Rest: TPrimitiveExpr);
|
|
begin
|
|
AssertEquals(Path+'.Value',Orig.Value,Rest.Value);
|
|
CheckRestoredPasExpr(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredBoolConstExpr(const Path: string;
|
|
Orig, Rest: TBoolConstExpr);
|
|
begin
|
|
AssertEquals(Path+'.Value',Orig.Value,Rest.Value);
|
|
CheckRestoredPasExpr(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredParamsExpr(const Path: string;
|
|
Orig, Rest: TParamsExpr);
|
|
begin
|
|
CheckRestoredElement(Path+'.Value',Orig.Value,Rest.Value);
|
|
CheckRestoredPasExprArray(Path+'.Params',Orig.Params,Rest.Params);
|
|
CheckRestoredPasExpr(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredProcedureExpr(const Path: string;
|
|
Orig, Rest: TProcedureExpr);
|
|
begin
|
|
CheckRestoredProcedure(Path+'$Ano',Orig.Proc,Rest.Proc);
|
|
CheckRestoredPasExpr(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredRecordValues(const Path: string;
|
|
Orig, Rest: TRecordValues);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
AssertEquals(Path+'.Fields.length',length(Orig.Fields),length(Rest.Fields));
|
|
for i:=0 to length(Orig.Fields)-1 do
|
|
begin
|
|
AssertEquals(Path+'.Field['+IntToStr(i)+'].Name',Orig.Fields[i].Name,Rest.Fields[i].Name);
|
|
CheckRestoredElement(Path+'.Field['+IntToStr(i)+'].ValueExp',Orig.Fields[i].ValueExp,Rest.Fields[i].ValueExp);
|
|
end;
|
|
CheckRestoredPasExpr(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredPasExprArray(const Path: string;
|
|
Orig, Rest: TPasExprArray);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
AssertEquals(Path+'.length',length(Orig),length(Rest));
|
|
for i:=0 to length(Orig)-1 do
|
|
CheckRestoredElement(Path+'['+IntToStr(i)+']',Orig[i],Rest[i]);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredArrayValues(const Path: string;
|
|
Orig, Rest: TArrayValues);
|
|
begin
|
|
CheckRestoredPasExprArray(Path+'.Values',Orig.Values,Rest.Values);
|
|
CheckRestoredPasExpr(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredResString(const Path: string;
|
|
Orig, Rest: TPasResString);
|
|
begin
|
|
CheckRestoredElement(Path+'.Expr',Orig.Expr,Rest.Expr);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredAliasType(const Path: string;
|
|
Orig, Rest: TPasAliasType);
|
|
begin
|
|
CheckRestoredElOrRef(Path+'.DestType',Orig,Orig.DestType,Rest,Rest.DestType);
|
|
CheckRestoredElement(Path+'.Expr',Orig.Expr,Rest.Expr);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredPointerType(const Path: string;
|
|
Orig, Rest: TPasPointerType);
|
|
begin
|
|
CheckRestoredElOrRef(Path+'.DestType',Orig,Orig.DestType,Rest,Rest.DestType);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredSpecializedType(
|
|
const Path: string; Orig, Rest: TPasSpecializeType);
|
|
begin
|
|
CheckRestoredElementList(Path+'.Params',Orig.Params,Rest.Params);
|
|
CheckRestoredElOrRef(Path+'.DestType',Orig,Orig.DestType,Rest,Rest.DestType);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredInlineSpecializedExpr(
|
|
const Path: string; Orig, Rest: TInlineSpecializeExpr);
|
|
begin
|
|
CheckRestoredElement(Path+'.NameExpr',Orig.NameExpr,Rest.NameExpr);
|
|
CheckRestoredElementList(Path+'.Params',Orig.Params,Rest.Params);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredRangeType(const Path: string;
|
|
Orig, Rest: TPasRangeType);
|
|
begin
|
|
CheckRestoredElement(Path+'.RangeExpr',Orig.RangeExpr,Rest.RangeExpr);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredArrayType(const Path: string;
|
|
Orig, Rest: TPasArrayType);
|
|
begin
|
|
CheckRestoredPasExprArray(Path+'.Ranges',Orig.Ranges,Rest.Ranges);
|
|
if Orig.PackMode<>Rest.PackMode then
|
|
Fail(Path+'.PackMode Orig='+PCUPackModeNames[Orig.PackMode]+' Rest='+PCUPackModeNames[Rest.PackMode]);
|
|
CheckRestoredElOrRef(Path+'.ElType',Orig,Orig.ElType,Rest,Rest.ElType);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredFileType(const Path: string; Orig,
|
|
Rest: TPasFileType);
|
|
begin
|
|
CheckRestoredElOrRef(Path+'.ElType',Orig,Orig.ElType,Rest,Rest.ElType);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredEnumValue(const Path: string;
|
|
Orig, Rest: TPasEnumValue);
|
|
begin
|
|
CheckRestoredElement(Path+'.Value',Orig.Value,Rest.Value);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredEnumType(const Path: string; Orig,
|
|
Rest: TPasEnumType);
|
|
begin
|
|
CheckRestoredElementList(Path+'.Values',Orig.Values,Rest.Values);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredSetType(const Path: string; Orig,
|
|
Rest: TPasSetType);
|
|
begin
|
|
CheckRestoredElOrRef(Path+'.EnumType',Orig,Orig.EnumType,Rest,Rest.EnumType);
|
|
AssertEquals(Path+'.IsPacked',Orig.IsPacked,Rest.IsPacked);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredVariant(const Path: string; Orig,
|
|
Rest: TPasVariant);
|
|
begin
|
|
CheckRestoredElementList(Path+'.Values',Orig.Values,Rest.Values);
|
|
CheckRestoredElement(Path+'.Members',Orig.Members,Rest.Members);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredRecordType(const Path: string;
|
|
Orig, Rest: TPasRecordType);
|
|
begin
|
|
if Orig.PackMode<>Rest.PackMode then
|
|
Fail(Path+'.PackMode Orig='+PCUPackModeNames[Orig.PackMode]+' Rest='+PCUPackModeNames[Rest.PackMode]);
|
|
CheckRestoredElementList(Path+'.Members',Orig.Members,Rest.Members);
|
|
CheckRestoredElOrRef(Path+'.VariantEl',Orig,Orig.VariantEl,Rest,Rest.VariantEl);
|
|
CheckRestoredElementList(Path+'.Variants',Orig.Variants,Rest.Variants);
|
|
CheckRestoredElementList(Path+'.GenericTemplateTypes',Orig.GenericTemplateTypes,Rest.GenericTemplateTypes);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredClassType(const Path: string;
|
|
Orig, Rest: TPasClassType);
|
|
begin
|
|
if Orig.PackMode<>Rest.PackMode then
|
|
Fail(Path+'.PackMode Orig='+PCUPackModeNames[Orig.PackMode]+' Rest='+PCUPackModeNames[Rest.PackMode]);
|
|
if Orig.ObjKind<>Rest.ObjKind then
|
|
Fail(Path+'.ObjKind Orig='+PCUObjKindNames[Orig.ObjKind]+' Rest='+PCUObjKindNames[Rest.ObjKind]);
|
|
if Orig.InterfaceType<>Rest.InterfaceType then
|
|
Fail(Path+'.ObjKind Orig='+PCUClassInterfaceTypeNames[Orig.InterfaceType]+' Rest='+PCUClassInterfaceTypeNames[Rest.InterfaceType]);
|
|
CheckRestoredReference(Path+'.AncestorType',Orig.AncestorType,Rest.AncestorType);
|
|
CheckRestoredReference(Path+'.HelperForType',Orig.HelperForType,Rest.HelperForType);
|
|
AssertEquals(Path+'.IsForward',Orig.IsForward,Rest.IsForward);
|
|
AssertEquals(Path+'.IsExternal',Orig.IsExternal,Rest.IsExternal);
|
|
// irrelevant: IsShortDefinition
|
|
CheckRestoredElement(Path+'.GUIDExpr',Orig.GUIDExpr,Rest.GUIDExpr);
|
|
CheckRestoredElementList(Path+'.Members',Orig.Members,Rest.Members);
|
|
AssertEquals(Path+'.Modifiers',Orig.Modifiers.Text,Rest.Modifiers.Text);
|
|
CheckRestoredElRefList(Path+'.Interfaces',Orig,Orig.Interfaces,Rest,Rest.Interfaces,false);
|
|
CheckRestoredElementList(Path+'.GenericTemplateTypes',Orig.GenericTemplateTypes,Rest.GenericTemplateTypes);
|
|
AssertEquals(Path+'.ExternalNameSpace',Orig.ExternalNameSpace,Rest.ExternalNameSpace);
|
|
AssertEquals(Path+'.ExternalName',Orig.ExternalName,Rest.ExternalName);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredArgument(const Path: string; Orig,
|
|
Rest: TPasArgument);
|
|
begin
|
|
if Orig.Access<>Rest.Access then
|
|
Fail(Path+'.Access Orig='+PCUArgumentAccessNames[Orig.Access]+' Rest='+PCUArgumentAccessNames[Rest.Access]);
|
|
CheckRestoredElOrRef(Path+'.ArgType',Orig,Orig.ArgType,Rest,Rest.ArgType);
|
|
CheckRestoredElement(Path+'.ValueExpr',Orig.ValueExpr,Rest.ValueExpr);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredProcedureType(const Path: string;
|
|
Orig, Rest: TPasProcedureType);
|
|
begin
|
|
CheckRestoredElementList(Path+'.Args',Orig.Args,Rest.Args);
|
|
if Orig.CallingConvention<>Rest.CallingConvention then
|
|
Fail(Path+'.CallingConvention Orig='+PCUCallingConventionNames[Orig.CallingConvention]+' Rest='+PCUCallingConventionNames[Rest.CallingConvention]);
|
|
if Orig.Modifiers<>Rest.Modifiers then
|
|
Fail(Path+'.Modifiers');
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredResultElement(const Path: string;
|
|
Orig, Rest: TPasResultElement);
|
|
begin
|
|
CheckRestoredElOrRef(Path+'.ResultType',Orig,Orig.ResultType,Rest,Rest.ResultType);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredFunctionType(const Path: string;
|
|
Orig, Rest: TPasFunctionType);
|
|
begin
|
|
CheckRestoredElement(Path+'.ResultEl',Orig.ResultEl,Rest.ResultEl);
|
|
CheckRestoredProcedureType(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredStringType(const Path: string;
|
|
Orig, Rest: TPasStringType);
|
|
begin
|
|
AssertEquals(Path+'.LengthExpr',Orig.LengthExpr,Rest.LengthExpr);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredVariable(const Path: string; Orig,
|
|
Rest: TPasVariable);
|
|
begin
|
|
CheckRestoredElOrRef(Path+'.VarType',Orig,Orig.VarType,Rest,Rest.VarType);
|
|
if Orig.VarModifiers<>Rest.VarModifiers then
|
|
Fail(Path+'.VarModifiers');
|
|
CheckRestoredElement(Path+'.LibraryName',Orig.LibraryName,Rest.LibraryName);
|
|
CheckRestoredElement(Path+'.ExportName',Orig.ExportName,Rest.ExportName);
|
|
CheckRestoredElement(Path+'.AbsoluteExpr',Orig.AbsoluteExpr,Rest.AbsoluteExpr);
|
|
CheckRestoredElement(Path+'.Expr',Orig.Expr,Rest.Expr);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredExportSymbol(const Path: string;
|
|
Orig, Rest: TPasExportSymbol);
|
|
begin
|
|
CheckRestoredElement(Path+'.ExportName',Orig.ExportName,Rest.ExportName);
|
|
CheckRestoredElement(Path+'.ExportIndex',Orig.ExportIndex,Rest.ExportIndex);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredConst(const Path: string; Orig,
|
|
Rest: TPasConst);
|
|
begin
|
|
AssertEquals(Path+'.IsConst',Orig.IsConst,Rest.IsConst);
|
|
CheckRestoredVariable(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredProperty(const Path: string; Orig,
|
|
Rest: TPasProperty);
|
|
begin
|
|
CheckRestoredElement(Path+'.IndexExpr',Orig.IndexExpr,Rest.IndexExpr);
|
|
CheckRestoredElement(Path+'.ReadAccessor',Orig.ReadAccessor,Rest.ReadAccessor);
|
|
CheckRestoredElement(Path+'.WriteAccessor',Orig.WriteAccessor,Rest.WriteAccessor);
|
|
CheckRestoredElement(Path+'.DispIDExpr',Orig.DispIDExpr,Rest.DispIDExpr);
|
|
CheckRestoredPasExprArray(Path+'.Implements',Orig.Implements,Rest.Implements);
|
|
CheckRestoredElement(Path+'.StoredAccessor',Orig.StoredAccessor,Rest.StoredAccessor);
|
|
CheckRestoredElement(Path+'.DefaultExpr',Orig.DefaultExpr,Rest.DefaultExpr);
|
|
CheckRestoredElementList(Path+'.Args',Orig.Args,Rest.Args);
|
|
// not needed: ReadAccessorName, WriteAccessorName, ImplementsName, StoredAccessorName
|
|
AssertEquals(Path+'.DispIDReadOnly',Orig.DispIDReadOnly,Rest.DispIDReadOnly);
|
|
AssertEquals(Path+'.IsDefault',Orig.IsDefault,Rest.IsDefault);
|
|
AssertEquals(Path+'.IsNodefault',Orig.IsNodefault,Rest.IsNodefault);
|
|
CheckRestoredVariable(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredMethodResolution(
|
|
const Path: string; Orig, Rest: TPasMethodResolution);
|
|
begin
|
|
AssertEquals(Path+'.ProcClass',Orig.ProcClass,Rest.ProcClass);
|
|
CheckRestoredElement(Path+'.InterfaceName',Orig.InterfaceName,Rest.InterfaceName);
|
|
CheckRestoredElement(Path+'.InterfaceProc',Orig.InterfaceProc,Rest.InterfaceProc);
|
|
CheckRestoredElement(Path+'.ImplementationProc',Orig.ImplementationProc,Rest.ImplementationProc);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredProcedure(const Path: string;
|
|
Orig, Rest: TPasProcedure);
|
|
var
|
|
RestScope, OrigScope: TPas2JSProcedureScope;
|
|
begin
|
|
CheckRestoredObject(Path+'.CustomData',Orig.CustomData,Rest.CustomData);
|
|
OrigScope:=Orig.CustomData as TPas2JSProcedureScope;
|
|
RestScope:=Rest.CustomData as TPas2JSProcedureScope;
|
|
if OrigScope=nil then
|
|
exit; // msIgnoreInterfaces
|
|
CheckRestoredReference(Path+'.CustomData[TPas2JSProcedureScope].DeclarationProc',
|
|
OrigScope.DeclarationProc,RestScope.DeclarationProc);
|
|
AssertEquals(Path+'.CustomData[TPas2JSProcedureScope].ResultVarName',OrigScope.ResultVarName,RestScope.ResultVarName);
|
|
if RestScope.DeclarationProc=nil then
|
|
begin
|
|
CheckRestoredElement(Path+'.ProcType',Orig.ProcType,Rest.ProcType);
|
|
CheckRestoredElement(Path+'.PublicName',Orig.PublicName,Rest.PublicName);
|
|
CheckRestoredElement(Path+'.LibrarySymbolName',Orig.LibrarySymbolName,Rest.LibrarySymbolName);
|
|
CheckRestoredElement(Path+'.LibraryExpr',Orig.LibraryExpr,Rest.LibraryExpr);
|
|
CheckRestoredElement(Path+'.DispIDExpr',Orig.DispIDExpr,Rest.DispIDExpr);
|
|
AssertEquals(Path+'.AliasName',Orig.AliasName,Rest.AliasName);
|
|
if Orig.Modifiers<>Rest.Modifiers then
|
|
Fail(Path+'.Modifiers');
|
|
AssertEquals(Path+'.MessageName',Orig.MessageName,Rest.MessageName);
|
|
if Orig.MessageType<>Rest.MessageType then
|
|
Fail(Path+'.MessageType Orig='+PCUProcedureMessageTypeNames[Orig.MessageType]+' Rest='+PCUProcedureMessageTypeNames[Rest.MessageType]);
|
|
end
|
|
else
|
|
begin
|
|
// ImplProc
|
|
end;
|
|
// ToDo: Body
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredOperator(const Path: string; Orig,
|
|
Rest: TPasOperator);
|
|
begin
|
|
if Orig.OperatorType<>Rest.OperatorType then
|
|
Fail(Path+'.OperatorType Orig='+PCUOperatorTypeNames[Orig.OperatorType]+' Rest='+PCUOperatorTypeNames[Rest.OperatorType]);
|
|
AssertEquals(Path+'.TokenBased',Orig.TokenBased,Rest.TokenBased);
|
|
CheckRestoredProcedure(Path,Orig,Rest);
|
|
end;
|
|
|
|
procedure TCustomTestPrecompile.CheckRestoredAttributes(const Path: string;
|
|
Orig, Rest: TPasAttributes);
|
|
begin
|
|
CheckRestoredPasExprArray(Path+'.Calls',Orig.Calls,Rest.Calls);
|
|
end;
|
|
|
|
{ TTestPrecompile }
|
|
|
|
procedure TTestPrecompile.Test_Base256VLQ;
|
|
|
|
procedure Test(i: TMaxPrecInt);
|
|
var
|
|
s: String;
|
|
p: PByte;
|
|
j: TMaxPrecInt;
|
|
begin
|
|
s:=EncodeVLQ(i);
|
|
p:=PByte(s);
|
|
j:=DecodeVLQ(p);
|
|
if i<>j then
|
|
Fail('Encode/DecodeVLQ OrigIndex='+IntToStr(i)+' Code="'+s+'" NewIndex='+IntToStr(j));
|
|
end;
|
|
|
|
procedure TestStr(i: TMaxPrecInt; Expected: string);
|
|
var
|
|
Actual: String;
|
|
begin
|
|
Actual:=EncodeVLQ(i);
|
|
AssertEquals('EncodeVLQ('+IntToStr(i)+')',Expected,Actual);
|
|
end;
|
|
|
|
var
|
|
i: Integer;
|
|
begin
|
|
TestStr(0,#0);
|
|
TestStr(1,#2);
|
|
TestStr(-1,#3);
|
|
for i:=-8200 to 8200 do
|
|
Test(i);
|
|
Test(High(TMaxPrecInt));
|
|
Test(High(TMaxPrecInt)-1);
|
|
Test(Low(TMaxPrecInt)+2);
|
|
Test(Low(TMaxPrecInt)+1);
|
|
//Test(Low(TMaxPrecInt)); such a high number is not needed by pastojs
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_EmptyUnit;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Const;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'const',
|
|
' Three = 3;',
|
|
' FourPlusFive: longint = 4+5 deprecated ''deprtext'';',
|
|
' Four: byte = +6-2*2 platform;',
|
|
' Affirmative = true;',
|
|
' BFalse = false;', // bool lit
|
|
' NotBFalse = not BFalse;', // boolconst
|
|
' UnaryMinus = -3;', // unary minus
|
|
' FloatA = -31.678E-012;', // float lit
|
|
' HighInt = High(longint);', // func params, built-in function
|
|
' s = ''abc'';', // string lit
|
|
' c: char = s[1];', // array params
|
|
' a: array[1..2] of longint = (3,4);', // anonymous array, range, array values
|
|
' PI: Double; external name ''Math.PI'';',
|
|
'resourcestring',
|
|
' rs = ''rs'';',
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Var;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'var',
|
|
' FourPlusFive: longint = 4+5 deprecated ''deprtext'';',
|
|
' e: double external name ''Math.e'';',
|
|
' AnoArr: array of longint = (1,2,3);',
|
|
' s: string = ''aaaäö'';',
|
|
' s2: string = ''😊'';', // 1F60A
|
|
' a,b: array of longint;',
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Enum;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TEnum = (red,green,blue);',
|
|
' TEnumRg = green..blue;',
|
|
' TArrOfEnum = array of TEnum;',
|
|
' TArrOfEnumRg = array of TEnumRg;',
|
|
' TArrEnumOfInt = array[TEnum] of longint;',
|
|
'var',
|
|
' HighEnum: TEnum = high(TEnum);',
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Set;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TEnum = (red,green,blue);',
|
|
' TEnumRg = green..blue;',
|
|
' TEnumAlias = TEnum;', // alias
|
|
' TSetOfEnum = set of TEnum;',
|
|
' TSetOfEnumRg = set of TEnumRg;',
|
|
' TSetOfDir = set of (west,east);',
|
|
'var',
|
|
' Empty: TSetOfEnum = [];', // empty set lit
|
|
' All: TSetOfEnum = [low(TEnum)..pred(high(TEnum)),high(TEnum)];', // full set lit, range in set
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Set_InFunction;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'procedure DoIt;',
|
|
'implementation',
|
|
'procedure DoIt;',
|
|
'type',
|
|
' TEnum = (red,green,blue);',
|
|
' TEnumRg = green..blue;',
|
|
' TEnumAlias = TEnum;', // alias
|
|
' TSetOfEnum = set of TEnum;',
|
|
' TSetOfEnumRg = set of TEnumRg;',
|
|
' TSetOfDir = set of (west,east);',
|
|
'var',
|
|
' Empty: TSetOfEnum = [];', // empty set lit
|
|
' All: TSetOfEnum = [low(TEnum)..pred(high(TEnum)),high(TEnum)];', // full set lit, range in set
|
|
' Dirs: TSetOfDir;',
|
|
'begin',
|
|
' Dirs:=[east];',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_SetOfAnonymousEnumType;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TSetOfDir = set of (west,east);',
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Record;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'{$ModeSwitch externalclass}',
|
|
'interface',
|
|
'type',
|
|
' TRec = record',
|
|
' i: longint;',
|
|
' s: string;',
|
|
' b: boolean external name ''ext'';',
|
|
' end;',
|
|
' P = pointer;', // alias type to built-in type
|
|
' TArrOfRec = array of TRec;',
|
|
'var',
|
|
' r: TRec;', // full set lit, range in set
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Record_InFunction;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'procedure DoIt;',
|
|
'implementation',
|
|
'procedure DoIt;',
|
|
'type',
|
|
' TRec = record',
|
|
' i: longint;',
|
|
' s: string;',
|
|
' end;',
|
|
' P = ^TRec;',
|
|
' TArrOfRec = array of TRec;',
|
|
'var',
|
|
' r: TRec;',
|
|
'begin',
|
|
'end;']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_RecordAdv;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'{$ModeSwitch advancedrecords}',
|
|
'interface',
|
|
'type',
|
|
' TRec = record',
|
|
' private',
|
|
' FInt: longint;',
|
|
' procedure SetInt(Value: longint);',
|
|
' function GetItems(Value: word): word;',
|
|
' procedure SetItems(Index, Value: word);',
|
|
' public',
|
|
' property Int: longint read FInt write SetInt default 3;',
|
|
' property Items[Index: word]: word read GetItems write SetItems; default;',
|
|
' end;',
|
|
'var',
|
|
' r: trec;',
|
|
'implementation',
|
|
'procedure TRec.SetInt(Value: longint);',
|
|
'begin',
|
|
'end;',
|
|
'function TRec.GetItems(Value: word): word;',
|
|
'begin',
|
|
'end;',
|
|
'procedure TRec.SetItems(Index, Value: word);',
|
|
'begin',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_JSValue;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'var',
|
|
' p: pointer = nil;', // pointer, nil lit
|
|
' js: jsvalue = 13 div 4;', // jsvalue
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Array;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TEnum = (red,green);',
|
|
' TArrInt = array of longint;',
|
|
' TArrInt2 = array[1..2] of longint;',
|
|
' TArrEnum1 = array[red..green] of longint;',
|
|
' TArrEnum2 = array[TEnum] of longint;',
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_ArrayOfAnonymous;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'var',
|
|
' a: array of pointer;',
|
|
'implementation']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Array_InFunction;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'procedure DoIt;',
|
|
'implementation',
|
|
'procedure DoIt;',
|
|
'type',
|
|
' TArr = array[1..2] of word;',
|
|
'var',
|
|
' arr: TArr;',
|
|
'begin',
|
|
' arr[2]:=arr[1];',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Proc;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
' function Abs(d: double): double; external name ''Math.Abs'';',
|
|
' function GetIt(d: double): double;',
|
|
' procedure DoArgs(const a; var b: array of char; out c: jsvalue); inline;',
|
|
' procedure DoMulti(a,b: byte);',
|
|
'implementation',
|
|
'var k: double;',
|
|
'function GetIt(d: double): double;',
|
|
'var j: double;',
|
|
'begin',
|
|
' j:=Abs(d+k);',
|
|
' Result:=j;',
|
|
'end;',
|
|
'procedure DoArgs(const a; var b: array of char; out c: jsvalue); inline;',
|
|
'begin',
|
|
'end;',
|
|
'procedure DoMulti(a,b: byte);',
|
|
'begin',
|
|
'end;',
|
|
'procedure NotUsed;',
|
|
'begin',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Proc_Nested;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
' function GetIt(d: longint): longint;',
|
|
'implementation',
|
|
'var k: double;',
|
|
'function GetIt(d: longint): longint;',
|
|
'var j: double;',
|
|
' function GetSum(a,b: longint): longint; forward;',
|
|
' function GetMul(a,b: longint): longint; ',
|
|
' begin',
|
|
' Result:=a*b;',
|
|
' end;',
|
|
' function GetSum(a,b: longint): longint;',
|
|
' begin',
|
|
' Result:=a+b;',
|
|
' end;',
|
|
' procedure NotUsed;',
|
|
' begin',
|
|
' end;',
|
|
'begin',
|
|
' Result:=GetMul(GetSum(d,2),3);',
|
|
'end;',
|
|
'procedure NotUsed;',
|
|
'begin',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Proc_LocalConst;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'function GetIt(d: double): double;',
|
|
'implementation',
|
|
'function GetIt(d: double): double;',
|
|
'const',
|
|
' c: double = 3.3;',
|
|
' e: double = 2.7;', // e is not used
|
|
'begin',
|
|
' Result:=d+c;',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Proc_UTF8;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'function DoIt: string;',
|
|
'implementation',
|
|
'function DoIt: string;',
|
|
'const',
|
|
' c = ''äöü😊'';',
|
|
'begin',
|
|
' Result:=''ÄÖÜ😊''+c;',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Proc_Arg;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'procedure DoIt(var a; out b,c: longint; const e,f: array of byte; g: boolean = true);',
|
|
'implementation',
|
|
'procedure DoIt(var a; out b,c: longint; const e,f: array of byte; g: boolean = true);',
|
|
'begin',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_ProcType;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'{$modeswitch arrayoperators}',
|
|
'interface',
|
|
'type',
|
|
' TProc = procedure;',
|
|
' TArrProc = array of tproc;',
|
|
'procedure Mark;',
|
|
'procedure DoIt(const a: TArrProc);',
|
|
'implementation',
|
|
'procedure Mark;',
|
|
'var',
|
|
' p: TProc;',
|
|
' a: TArrProc;',
|
|
'begin',
|
|
' DoIt([@Mark,p]+a);',
|
|
'end;',
|
|
'procedure DoIt(const a: TArrProc);',
|
|
'begin',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Proc_Anonymous;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TFunc = reference to function(w: word): word;',
|
|
' function GetIt(f: TFunc): longint;',
|
|
'implementation',
|
|
'var k: byte;',
|
|
'function GetIt(f: TFunc): longint;',
|
|
'begin',
|
|
' f:=function(w: word): word',
|
|
' var j: byte;',
|
|
' function GetMul(a,b: longint): longint; ',
|
|
' begin',
|
|
' Result:=a*b;',
|
|
' end;',
|
|
' begin',
|
|
' Result:=j*GetMul(1,2)*k;',
|
|
' end;',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Proc_ArrayOfConst;
|
|
begin
|
|
StartUnit(true,[supTVarRec]);
|
|
Add([
|
|
'interface',
|
|
'procedure Fly(arr: array of const);',
|
|
'implementation',
|
|
'procedure Fly(arr: array of const);',
|
|
'begin',
|
|
' if arr[1].VType=1 then ;',
|
|
' if arr[2].VInteger=1 then ;',
|
|
' Fly([true,0.3]);',
|
|
'end;',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Class;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TObject = class',
|
|
' protected',
|
|
' FInt: longint;',
|
|
' procedure SetInt(Value: longint); virtual; abstract;',
|
|
' public',
|
|
' property Int: longint read FInt write SetInt default 3;',
|
|
' end;',
|
|
' TBird = class',
|
|
' protected',
|
|
' procedure SetInt(Value: longint); override;',
|
|
' published',
|
|
' property Int;',
|
|
' end;',
|
|
'var',
|
|
' o: tobject;',
|
|
'implementation',
|
|
'procedure TBird.SetInt(Value: longint);',
|
|
'begin',
|
|
'end;'
|
|
]);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_ClassForward;
|
|
begin
|
|
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TObject = class end;',
|
|
' TFish = class;',
|
|
' TBird = class;',
|
|
' TBirdClass = class of TBird;',
|
|
' TFish = class',
|
|
' B: TBird;',
|
|
' end;',
|
|
' TBird = class',
|
|
' F: TFish;',
|
|
' end;',
|
|
' TFishClass = class of TFish;',
|
|
'var',
|
|
' b: tbird;',
|
|
' f: tfish;',
|
|
' bc: TBirdClass;',
|
|
' fc: TFishClass;',
|
|
'implementation',
|
|
'end.'
|
|
]);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_ClassConstructor;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' TObject = class',
|
|
' constructor Create; virtual;',
|
|
' end;',
|
|
' TBird = class',
|
|
' constructor Create; override;',
|
|
' end;',
|
|
'procedure DoIt;',
|
|
'implementation',
|
|
'constructor TObject.Create;',
|
|
'begin',
|
|
'end;',
|
|
'constructor TBird.Create;',
|
|
'begin',
|
|
' inherited;',
|
|
'end;',
|
|
'procedure DoIt;',
|
|
'var b: TBird;',
|
|
'begin',
|
|
' b:=TBird.Create;',
|
|
'end;',
|
|
'end.'
|
|
]);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_ClassDispatchMessage;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'type',
|
|
' {$DispatchField DispInt}',
|
|
' {$DispatchStrField DispStr}',
|
|
' TObject = class',
|
|
' end;',
|
|
' THopMsg = record',
|
|
' DispInt: longint;',
|
|
' end;',
|
|
' TPutMsg = record',
|
|
' DispStr: string;',
|
|
' end;',
|
|
' TBird = class',
|
|
' procedure Fly(var Msg); virtual; abstract; message 2;',
|
|
' procedure Run; overload; virtual; abstract;',
|
|
' procedure Run(var Msg); overload; message ''Fast'';',
|
|
' procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
|
|
' procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
|
|
' end;',
|
|
'implementation',
|
|
'procedure TBird.Run(var Msg);',
|
|
'begin',
|
|
'end;',
|
|
'end.',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Initialization;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'implementation',
|
|
'type',
|
|
' TCaption = string;',
|
|
' TRec = record h: string; end;',
|
|
'var',
|
|
' s: TCaption;',
|
|
' r: TRec;',
|
|
'initialization',
|
|
' s:=''ö😊'';',
|
|
' r.h:=''Ä😊'';',
|
|
'end.',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_BoolSwitches;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'{$R+}',
|
|
'{$C+}',
|
|
'type',
|
|
' TObject = class',
|
|
'{$C-}',
|
|
' procedure DoIt;',
|
|
' end;',
|
|
'{$C+}',
|
|
'implementation',
|
|
'{$R-}',
|
|
'procedure TObject.DoIt;',
|
|
'begin',
|
|
'end;',
|
|
'{$C-}',
|
|
'initialization',
|
|
'{$R+}',
|
|
'end.',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_ClassInterface;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'{$interfaces corba}',
|
|
'type',
|
|
' IUnknown = interface',
|
|
' end;',
|
|
' IFlying = interface',
|
|
' procedure SetItems(Index: longint; Value: longint);',
|
|
' end;',
|
|
' IBird = interface(IFlying)',
|
|
' [''{D44C1F80-44F9-4E88-8443-C518CCDC1FE8}'']',
|
|
' function GetItems(Index: longint): longint;',
|
|
' property Items[Index: longint]: longint read GetItems write SetItems;',
|
|
' end;',
|
|
' TObject = class',
|
|
' end;',
|
|
' TBird = class(TObject,IBird)',
|
|
' strict private',
|
|
' function IBird.GetItems = RetItems;',
|
|
' function RetItems(Index: longint): longint; virtual; abstract;',
|
|
' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
|
|
' end;',
|
|
' TEagle = class(TObject,IBird)',
|
|
' strict private',
|
|
' FBird: IBird;',
|
|
' property Bird: IBird read FBird implements IBird;',
|
|
' end;',
|
|
'implementation',
|
|
'end.',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_Attributes;
|
|
begin
|
|
StartUnit(false);
|
|
Add([
|
|
'interface',
|
|
'{$modeswitch PrefixedAttributes}',
|
|
'type',
|
|
' TObject = class',
|
|
' constructor Create;',
|
|
' end;',
|
|
' TCustomAttribute = class',
|
|
' constructor Create(Id: word);',
|
|
' end;',
|
|
' [Missing]',
|
|
' TBird = class',
|
|
' [TCustom]',
|
|
' FField: word;',
|
|
' end;',
|
|
' TRec = record',
|
|
' [TCustom]',
|
|
' Size: word;',
|
|
' end;',
|
|
'var',
|
|
' [TCustom, TCustom(3)]',
|
|
' o: TObject;',
|
|
'implementation',
|
|
'[TCustom]',
|
|
'constructor TObject.Create; begin end;',
|
|
'constructor TCustomAttribute.Create(Id: word); begin end;',
|
|
'end.',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_UseUnit;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pp',
|
|
LinesToStr([
|
|
'type',
|
|
' TColor = longint;',
|
|
' TRec = record h: TColor; end;',
|
|
' TEnum = (red,green);',
|
|
'var',
|
|
' c: TColor;',
|
|
' r: TRec;',
|
|
' e: TEnum;']),
|
|
LinesToStr([
|
|
'']));
|
|
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'uses unit2;',
|
|
'var',
|
|
' i: system.longint;',
|
|
' e2: TEnum;',
|
|
'implementation',
|
|
'initialization',
|
|
' c:=1;',
|
|
' r.h:=2;',
|
|
' e:=red;',
|
|
'end.',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_UseUnit_Class;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pp',
|
|
LinesToStr([
|
|
'type',
|
|
' TObject = class',
|
|
' private',
|
|
' FA: longint;',
|
|
' public',
|
|
' type',
|
|
' TEnum = (red,green);',
|
|
' public',
|
|
' i: longint;',
|
|
' e: TEnum;',
|
|
' procedure DoIt; virtual; abstract;',
|
|
' property A: longint read FA write FA;',
|
|
' end;',
|
|
'var',
|
|
' o: TObject;']),
|
|
LinesToStr([
|
|
'']));
|
|
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'uses unit2;',
|
|
'var',
|
|
' b: TObject;',
|
|
'implementation',
|
|
'initialization',
|
|
' o.DoIt;',
|
|
' o.i:=b.A;',
|
|
' o.e:=red;',
|
|
'end.',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
procedure TTestPrecompile.TestPC_UseIndirectUnit;
|
|
begin
|
|
AddModuleWithIntfImplSrc('unit2.pp',
|
|
LinesToStr([
|
|
'type',
|
|
' TObject = class',
|
|
' public',
|
|
' i: longint;',
|
|
' end;']),
|
|
LinesToStr([
|
|
'']));
|
|
|
|
AddModuleWithIntfImplSrc('unit1.pp',
|
|
LinesToStr([
|
|
'uses unit2;',
|
|
'var o: TObject;']),
|
|
LinesToStr([
|
|
'']));
|
|
|
|
StartUnit(true);
|
|
Add([
|
|
'interface',
|
|
'uses unit1;',
|
|
'implementation',
|
|
'initialization',
|
|
' o.i:=3;',
|
|
'end.',
|
|
'']);
|
|
WriteReadUnit;
|
|
end;
|
|
|
|
Initialization
|
|
RegisterTests([TTestPrecompile]);
|
|
RegisterPCUFormat;
|
|
end.
|
|
|