paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 12:09:11 +02:00
Code Issues Packages Projects Releases Wiki Activity

# revisions: 45563,45574,45586,45587,45588,45589,45610,45611,45615,45625,45626,45634,45639,45640,45650,45653,45660,45697,45700,45701

Browse Source 
git-svn-id: branches/fixes_3_2@46824 -
This commit is contained in:
marco 2020-09-10 12:58:26 +00:00
parent 3336c25699
commit 316df7d872
22 changed files with 2980 additions and 1107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -8657,7 +8657,9 @@ packages/rtl-generics/tests/tests.generics.arrayhelper.pas svneol=native#text/pa
packages/rtl-generics/tests/tests.generics.bugs.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.dictionary.pas svneol=native#text/plain
packages/rtl-generics/tests/tests.generics.hashmaps.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.queue.pas svneol=native#text/plain
packages/rtl-generics/tests/tests.generics.sets.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.stack.pas svneol=native#text/plain
packages/rtl-generics/tests/tests.generics.stdcollections.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.trees.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.utils.pas svneol=native#text/pascal

6
packages/fcl-js/src/jstree.pp
View File

@ -975,6 +975,7 @@ Type
function GetN(AIndex : Integer): TJSElementNode;
Public
Function AddNode : TJSElementNode;
Function InsertNode(Index: integer) : TJSElementNode;
Property Nodes[AIndex : Integer] : TJSElementNode Read GetN ; default;
end;
@ -1937,6 +1938,11 @@ begin
Result:=TJSElementNode(Add);
end;
function TJSElementNodes.InsertNode(Index: integer): TJSElementNode;
begin
Result:=TJSElementNode(Insert(Index));
end;
{ TJSFunction }
destructor TJSFunctionDeclarationStatement.Destroy;

63
packages/fcl-passrc/src/pasresolver.pp
View File

@ -1758,8 +1758,8 @@ type
MaxCount: integer; RaiseOnError: boolean; Signature: string = ''): integer;
function CheckRaiseTypeArgNo(id: TMaxPrecInt; ArgNo: integer; Param: TPasExpr;
const ParamResolved: TPasResolverResult; Expected: string; RaiseOnError: boolean): integer;
function FindUsedUnitInSection(const aName: string; Section: TPasSection): TPasModule;
function FindUsedUnit(const aName: string; aMod: TPasModule): TPasModule;
function FindUsedUnitnameInSection(const aName: string; Section: TPasSection): TPasModule;
function FindUsedUnitname(const aName: string; aMod: TPasModule): TPasModule;
procedure FinishAssertCall(Proc: TResElDataBuiltInProc;
Params: TParamsExpr); virtual;
function FindSystemClassType(const aUnitName, aClassName: string;
@ -2366,7 +2366,9 @@ type
function GetCombinedBaseType(const A, B: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
function IsElementSkipped(El: TPasElement): boolean; virtual;
function FindLocalBuiltInSymbol(El: TPasElement): TPasElement; virtual;
function GetFirstSection(WithUnitImpl: boolean): TPasSection;
function GetLastSection: TPasSection;
function FindUsedUnitInSection(aMod: TPasModule; Section: TPasSection): TPasUsesUnit;
function GetShiftAndMaskForLoHiFunc(BaseType: TResolverBaseType;
isLoFunc: Boolean; out Mask: LongWord): Integer;
public
@ -14792,7 +14794,7 @@ begin
Result:=cIncompatible;
end;
function TPasResolver.FindUsedUnitInSection(const aName: string; Section: TPasSection): TPasModule;
function TPasResolver.FindUsedUnitnameInSection(const aName: string; Section: TPasSection): TPasModule;
var
Clause: TPasUsesClause;
i: Integer;
@ -14812,20 +14814,20 @@ begin
end;
end;
function TPasResolver.FindUsedUnit(const aName: string; aMod: TPasModule): TPasModule;
function TPasResolver.FindUsedUnitname(const aName: string; aMod: TPasModule): TPasModule;
var
C: TClass;
begin
C:=aMod.ClassType;
if C.InheritsFrom(TPasProgram) then
Result:=FindUsedUnitInSection(aName,TPasProgram(aMod).ProgramSection)
Result:=FindUsedUnitnameInSection(aName,TPasProgram(aMod).ProgramSection)
else if C.InheritsFrom(TPasLibrary) then
Result:=FindUsedUnitInSection(aName,TPasLibrary(aMod).LibrarySection)
Result:=FindUsedUnitnameInSection(aName,TPasLibrary(aMod).LibrarySection)
else
begin
Result:=FindUsedUnitInSection(aName,aMod.InterfaceSection);
Result:=FindUsedUnitnameInSection(aName,aMod.InterfaceSection);
if Result<>nil then exit;
Result:=FindUsedUnitInSection(aName,aMod.ImplementationSection);
Result:=FindUsedUnitnameInSection(aName,aMod.ImplementationSection);
end
end;
@ -14862,7 +14864,7 @@ begin
// find unit in uses clauses
aMod:=RootElement;
UtilsMod:=FindUsedUnit(aUnitName,aMod);
UtilsMod:=FindUsedUnitname(aUnitName,aMod);
if UtilsMod=nil then
if ErrorEl<>nil then
RaiseIdentifierNotFound(20200523224738,'unit '+aUnitName,ErrorEl)
@ -15020,7 +15022,7 @@ begin
if Result<>nil then exit;
// find unit in uses clauses
UtilsMod:=FindUsedUnit('system',aMod);
UtilsMod:=FindUsedUnitname('system',aMod);
if UtilsMod=nil then
RaiseIdentifierNotFound(20190215101210,'System.TVarRec',ErrorEl);
@ -16411,10 +16413,7 @@ var
writeln('InsertBehind Generic=',GetObjName(GenericEl),' Last=',GetObjName(Last));
//for i:=0 to List.Count-1 do writeln(' ',GetObjName(TObject(List[i])));
{$ENDIF}
if GenericEl is TPasProcedure then
i:=List.Count-1
else
RaiseNotYetImplemented(20190826150507,El);
i:=List.Count-1;
end;
List.Insert(i+1,NewEl);
end;
@ -25130,7 +25129,7 @@ function TPasResolver.GetTypeDescription(aType: TPasType; AddPath: boolean): str
Result:=Result+'<';
for i:=0 to length(Params)-1 do
begin
Result:=Result+GetTypeDescription(Params[i]);
Result:=Result+GetTypeDescription(Params[i],AddPath);
if i>0 then
Result:=Result+',';
end;
@ -28035,7 +28034,7 @@ var
begin
Result:=false;
if aClass=nil then exit;
while (aClass<>nil) and aClass.IsExternal do
while aClass<>nil do
begin
if aClass.ExternalName=ExtName then exit(true);
AncestorScope:=(aClass.CustomData as TPasClassScope).AncestorScope;
@ -29156,6 +29155,25 @@ begin
Result:=nil;
end;
function TPasResolver.GetFirstSection(WithUnitImpl: boolean): TPasSection;
var
Module: TPasModule;
begin
Result:=nil;
Module:=RootElement;
if Module=nil then exit;
if Module is TPasProgram then
Result:=TPasProgram(Module).ProgramSection
else if Module is TPasLibrary then
Result:=TPasLibrary(Module).LibrarySection
else
begin
Result:=Module.InterfaceSection;
if WithUnitImpl and (Result=nil) then
Result:=Module.ImplementationSection;
end;
end;
function TPasResolver.GetLastSection: TPasSection;
var
Module: TPasModule;
@ -29173,6 +29191,19 @@ begin
Result:=Module.InterfaceSection;
end;
function TPasResolver.FindUsedUnitInSection(aMod: TPasModule;
Section: TPasSection): TPasUsesUnit;
var
Clause: TPasUsesClause;
i: Integer;
begin
Result:=nil;
if Section=nil then exit;
Clause:=Section.UsesClause;
for i:=0 to length(Clause)-1 do
if Clause[i].Module=aMod then exit(Clause[i]);
end;
function TPasResolver.GetShiftAndMaskForLoHiFunc(BaseType: TResolverBaseType;
isLoFunc: Boolean; out Mask: LongWord): Integer;
const

5
packages/fcl-passrc/src/pparser.pp
View File

@ -4428,8 +4428,10 @@ var
ArrEl: TPasArrayType;
i: Integer;
AObjKind: TPasObjKind;
ok: Boolean;
begin
Result:=nil;
ok := false;
TypeName := CurTokenString;
NamePos := CurSourcePos;
TypeParams:=TFPList.Create;
@ -4510,7 +4512,10 @@ begin
else
ParseExcTypeParamsNotAllowed;
end;
ok:=true;
finally
if (not ok) and (Result<>nil) and not AddToParent then
Result.Release({$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF});
for i:=0 to TypeParams.Count-1 do
TPasElement(TypeParams[i]).Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
TypeParams.Free;

165
packages/fcl-passrc/src/pscanner.pp
View File

@ -821,6 +821,8 @@ type
procedure HandleMessageDirective(Param: String); virtual;
procedure HandleIncludeFile(Param: String); virtual;
procedure HandleResource(Param : string); virtual;
procedure HandleOptimizations(Param : string); virtual;
procedure DoHandleOptimization(OptName, OptValue: string); virtual;
procedure HandleUnDefine(Param: String); virtual;
@ -3416,6 +3418,47 @@ begin
end;
end;
procedure TPascalScanner.HandleOptimizations(Param: string);
// $optimization A,B-,C+
var
p, StartP, l: Integer;
OptName, Value: String;
begin
p:=1;
l:=length(Param);
while p<=l do
begin
// read next flag
// skip whitespace
while (p<=l) and (Param[p] in [' ',#9,#10,#13]) do
inc(p);
// read name
StartP:=p;
while (p<=l) and (Param[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
inc(p);
if p=StartP then
Error(nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,['optimization']);
OptName:=copy(Param,StartP,p-StartP);
// skip whitespace
while (p<=l) and (Param[p] in [' ',#9,#10,#13]) do
inc(p);
// read value
StartP:=p;
while (p<=l) and (Param[p]<>',') do
inc(p);
Value:=TrimRight(copy(Param,StartP,p-StartP));
DoHandleOptimization(OptName,Value);
inc(p);
end;
end;
procedure TPascalScanner.DoHandleOptimization(OptName, OptValue: string);
begin
// default: skip any optimization directive
if OptName='' then ;
if OptValue='' then ;
end;
function TPascalScanner.HandleMacro(AIndex : integer) : TToken;
Var
@ -4010,66 +4053,68 @@ begin
Handled:=true;
Param:=Trim(Param);
Case UpperCase(Directive) of
'ASSERTIONS':
DoBoolDirective(bsAssertions);
'DEFINE':
HandleDefine(Param);
'GOTO':
DoBoolDirective(bsGoto);
'DIRECTIVEFIELD':
HandleDispatchField(Param,vsDispatchField);
'DIRECTIVESTRFIELD':
HandleDispatchField(Param,vsDispatchStrField);
'ERROR':
HandleError(Param);
'HINT':
DoLog(mtHint,nUserDefined,SUserDefined,[Param]);
'HINTS':
DoBoolDirective(bsHints);
'I','INCLUDE':
Result:=HandleInclude(Param);
'INTERFACES':
HandleInterfaces(Param);
'LONGSTRINGS':
DoBoolDirective(bsLongStrings);
'MACRO':
DoBoolDirective(bsMacro);
'MESSAGE':
HandleMessageDirective(Param);
'MODE':
HandleMode(Param);
'MODESWITCH':
HandleModeSwitch(Param);
'NOTE':
DoLog(mtNote,nUserDefined,SUserDefined,[Param]);
'NOTES':
DoBoolDirective(bsNotes);
'OBJECTCHECKS':
DoBoolDirective(bsObjectChecks);
'OVERFLOWCHECKS','OV':
DoBoolDirective(bsOverflowChecks);
'POINTERMATH':
DoBoolDirective(bsPointerMath);
'R' :
HandleResource(Param);
'RANGECHECKS':
DoBoolDirective(bsRangeChecks);
'SCOPEDENUMS':
DoBoolDirective(bsScopedEnums);
'TYPEDADDRESS':
DoBoolDirective(bsTypedAddress);
'TYPEINFO':
DoBoolDirective(bsTypeInfo);
'UNDEF':
HandleUnDefine(Param);
'WARN':
HandleWarn(Param);
'WARNING':
DoLog(mtWarning,nUserDefined,SUserDefined,[Param]);
'WARNINGS':
DoBoolDirective(bsWarnings);
'WRITEABLECONST':
DoBoolDirective(bsWriteableConst);
'ASSERTIONS':
DoBoolDirective(bsAssertions);
'DEFINE':
HandleDefine(Param);
'GOTO':
DoBoolDirective(bsGoto);
'DIRECTIVEFIELD':
HandleDispatchField(Param,vsDispatchField);
'DIRECTIVESTRFIELD':
HandleDispatchField(Param,vsDispatchStrField);
'ERROR':
HandleError(Param);
'HINT':
DoLog(mtHint,nUserDefined,SUserDefined,[Param]);
'HINTS':
DoBoolDirective(bsHints);
'I','INCLUDE':
Result:=HandleInclude(Param);
'INTERFACES':
HandleInterfaces(Param);
'LONGSTRINGS':
DoBoolDirective(bsLongStrings);
'MACRO':
DoBoolDirective(bsMacro);
'MESSAGE':
HandleMessageDirective(Param);
'MODE':
HandleMode(Param);
'MODESWITCH':
HandleModeSwitch(Param);
'NOTE':
DoLog(mtNote,nUserDefined,SUserDefined,[Param]);
'NOTES':
DoBoolDirective(bsNotes);
'OBJECTCHECKS':
DoBoolDirective(bsObjectChecks);
'OPTIMIZATION':
HandleOptimizations(Param);
'OVERFLOWCHECKS','OV':
DoBoolDirective(bsOverflowChecks);
'POINTERMATH':
DoBoolDirective(bsPointerMath);
'R' :
HandleResource(Param);
'RANGECHECKS':
DoBoolDirective(bsRangeChecks);
'SCOPEDENUMS':
DoBoolDirective(bsScopedEnums);
'TYPEDADDRESS':
DoBoolDirective(bsTypedAddress);
'TYPEINFO':
DoBoolDirective(bsTypeInfo);
'UNDEF':
HandleUnDefine(Param);
'WARN':
HandleWarn(Param);
'WARNING':
DoLog(mtWarning,nUserDefined,SUserDefined,[Param]);
'WARNINGS':
DoBoolDirective(bsWarnings);
'WRITEABLECONST':
DoBoolDirective(bsWriteableConst);
else
Handled:=false;
end;

2
packages/fcl-passrc/tests/tcgenerics.pp
View File

@ -9,7 +9,7 @@ uses
Type
{ TTestGenerics }
{ TTestGenerics - for resolver see unit tcresolvegenerics }
TTestGenerics = Class(TBaseTestTypeParser)
Published

16
packages/fcl-passrc/tests/tcresolvegenerics.pas
View File

@ -51,6 +51,7 @@ type
procedure TestGen_RecordDelphi;
procedure TestGen_RecordNestedSpecialized;
procedure TestGen_Record_SpecializeSelfInsideFail;
procedure TestGen_Record_ReferGenericSelfFail;
procedure TestGen_RecordAnoArray;
// ToDo: unitname.specialize TBird<word>.specialize
procedure TestGen_RecordNestedSpecialize;
@ -697,6 +698,21 @@ begin
nTypeXIsNotYetCompletelyDefined);
end;
procedure TTestResolveGenerics.TestGen_Record_ReferGenericSelfFail;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'Type',
' TBird<T> = record',
' b: TBird<T>;',
' end;',
'begin',
'']);
CheckResolverException('type "TBird<>" is not yet completely defined',
nTypeXIsNotYetCompletelyDefined);
end;
procedure TTestResolveGenerics.TestGen_RecordAnoArray;
begin
StartProgram(false);

1312
packages/pastojs/src/fppas2js.pp
View File

File diff suppressed because it is too large Load Diff

43
packages/pastojs/src/pas2jscompiler.pp
View File

@ -5185,7 +5185,7 @@ var
FoundPasIsForeign: Boolean;
FoundPCUFilename, FoundPCUUnitName: string;
procedure TryUnitName(const TestUnitName: string);
function TryUnitName(const TestUnitName: string): boolean;
var
aFile: TPas2jsCompilerFile;
begin
@ -5220,6 +5220,9 @@ var
if FoundPCUFilename<>'' then
FoundPCUUnitName:=TestUnitName;
end;
Result:=(FoundPasFilename<>'')
and (not Assigned(PCUSupport) or (FoundPCUFilename<>''));
end;
var
@ -5239,32 +5242,34 @@ begin
begin
CheckUnitAlias(UseUnitName);
if Pos('.',UseUnitname)<1 then
// first search with name as written in module
if not TryUnitName(UseUnitname) then
begin
// generic unit name -> search with namespaces
// first the default program namespace
DefNameSpace:=GetDefaultNamespace;
if DefNameSpace<>'' then
TryUnitName(DefNameSpace+'.'+UseUnitname);
if (FoundPasFilename='') or (FoundPCUFilename='') then
if Pos('.',UseUnitname)<1 then
begin
// then the cmdline namespaces
// generic unit name -> search with namespaces
// first the cmdline namespaces
for i:=0 to Namespaces.Count-1 do
begin
aNameSpace:=Namespaces[i];
if aNameSpace='' then continue;
if SameText(aNameSpace,DefNameSpace) then continue;
TryUnitName(aNameSpace+'.'+UseUnitname);
if TryUnitName(aNameSpace+'.'+UseUnitname) then break;
end;
if (FoundPasFilename='') or (FoundPCUFilename='') then
begin
// then the default program namespace
DefNameSpace:=GetDefaultNamespace;
if DefNameSpace<>'' then
begin
i:=Namespaces.Count-1;
while (i>=0) and not SameText(Namespaces[i],DefNameSpace) do dec(i);
if i<0 then
TryUnitName(DefNameSpace+'.'+UseUnitname);
end;
end;
end;
end;
if (FoundPasFilename='') or (FoundPCUFilename='') then
begin
// search unitname
TryUnitName(UseUnitname);
end;
end
end else begin
// search Pascal file with InFilename
FoundPasFilename:=FS.FindUnitFileName(UseUnitname,InFilename,ModuleDir,FoundPasIsForeign);

19
packages/pastojs/src/pas2jsfiler.pp
View File

@ -252,7 +252,8 @@ const
'StoreImplJS',
'RTLVersionCheckMain',
'RTLVersionCheckSystem',
'RTLVersionCheckUnit'
'RTLVersionCheckUnit',
'AliasGlobals'
);
PCUDefaultTargetPlatform = PlatformBrowser;
@ -844,7 +845,7 @@ type
procedure WriteEnumType(Obj: TJSONObject; El: TPasEnumType; aContext: TPCUWriterContext); virtual;
procedure WriteSetType(Obj: TJSONObject; El: TPasSetType; aContext: TPCUWriterContext); virtual;
procedure WriteRecordVariant(Obj: TJSONObject; El: TPasVariant; aContext: TPCUWriterContext); virtual;
procedure WriteRecordTypeScope(Obj: TJSONObject; Scope: TPasRecordScope; aContext: TPCUWriterContext); virtual;
procedure WriteRecordTypeScope(Obj: TJSONObject; Scope: TPas2jsRecordScope; aContext: TPCUWriterContext); virtual;
procedure WriteRecordType(Obj: TJSONObject; El: TPasRecordType; aContext: TPCUWriterContext); virtual;
procedure WriteClassScopeFlags(Obj: TJSONObject; const PropName: string; const Value, DefaultValue: TPasClassScopeFlags); virtual;
procedure WriteClassIntfMapProcs(Obj: TJSONObject; Map: TPasClassIntfMap); virtual;
@ -1137,7 +1138,7 @@ type
procedure ReadSetType(Obj: TJSONObject; El: TPasSetType; aContext: TPCUReaderContext); virtual;
function ReadPackedMode(Obj: TJSONObject; const PropName: string; ErrorEl: TPasElement): TPackMode; virtual;
procedure ReadRecordVariant(Obj: TJSONObject; El: TPasVariant; aContext: TPCUReaderContext); virtual;
procedure ReadRecordScope(Obj: TJSONObject; Scope: TPasRecordScope; aContext: TPCUReaderContext); virtual;
procedure ReadRecordScope(Obj: TJSONObject; Scope: TPas2jsRecordScope; aContext: TPCUReaderContext); virtual;
procedure ReadRecordType(Obj: TJSONObject; El: TPasRecordType; aContext: TPCUReaderContext); virtual;
function ReadClassInterfaceType(Obj: TJSONObject; const PropName: string; ErrorEl: TPasElement; DefaultValue: TPasClassInterfaceType): TPasClassInterfaceType;
function ReadClassScopeFlags(Obj: TJSONObject; El: TPasElement;
@ -4038,7 +4039,7 @@ begin
end;
procedure TPCUWriter.WriteRecordTypeScope(Obj: TJSONObject;
Scope: TPasRecordScope; aContext: TPCUWriterContext);
Scope: TPas2jsRecordScope; aContext: TPCUWriterContext);
begin
AddReferenceToObj(Obj,'DefaultProperty',Scope.DefaultProperty);
WriteIdentifierScope(Obj,Scope,aContext);
@ -4059,7 +4060,7 @@ begin
WriteElementProperty(Obj,El,'VariantEl',El.VariantEl,aContext);
WriteElementList(Obj,El,'Variants',El.Variants,aContext);
WriteRecordTypeScope(Obj,El.CustomData as TPasRecordScope,aContext);
WriteRecordTypeScope(Obj,El.CustomData as TPas2jsRecordScope,aContext);
end;
procedure TPCUWriter.WriteClassScopeFlags(Obj: TJSONObject;
@ -5076,7 +5077,7 @@ end;
procedure TPCUReader.Set_RecordScope_DefaultProperty(RefEl: TPasElement;
Data: TObject);
var
Scope: TPasRecordScope absolute Data;
Scope: TPas2jsRecordScope absolute Data;
begin
if RefEl is TPasProperty then
Scope.DefaultProperty:=TPasProperty(RefEl) // no AddRef
@ -8168,7 +8169,7 @@ begin
ReadElType(Obj,'Members',El,@Set_Variant_Members,aContext);
end;
procedure TPCUReader.ReadRecordScope(Obj: TJSONObject; Scope: TPasRecordScope;
procedure TPCUReader.ReadRecordScope(Obj: TJSONObject; Scope: TPas2jsRecordScope;
aContext: TPCUReaderContext);
begin
ReadElementReference(Obj,Scope,'DefaultProperty',@Set_RecordScope_DefaultProperty);
@ -8180,13 +8181,13 @@ procedure TPCUReader.ReadRecordType(Obj: TJSONObject; El: TPasRecordType;
var
Data: TJSONData;
Id: Integer;
Scope: TPasRecordScope;
Scope: TPas2jsRecordScope;
SubObj: TJSONObject;
begin
if FileVersion<3 then
RaiseMsg(20190109214718,El,'record format changed');
Scope:=TPasRecordScope(Resolver.CreateScope(El,TPasRecordScope));
Scope:=TPas2jsRecordScope(Resolver.CreateScope(El,TPas2jsRecordScope));
El.CustomData:=Scope;
ReadPasElement(Obj,El,aContext);

36
packages/pastojs/tests/tcconverter.pp
View File

@ -385,14 +385,14 @@ begin
F.Body:=CreateAssignStatement();
ForSt:=TJSForStatement(Convert(F,TJSForStatement));
// Should be
// for(var $l1=1, $le2=100; $l1<=$le2; $l1++){
// I=$l1;
// for(var $l=1, $end=100; $l<=$end2; $l++){
// I=$l;
// a=b;
// }
LoopVar:=Pas2JSBuiltInNames[pbivnLoop]+'1';
LoopEndVar:=Pas2JSBuiltInNames[pbivnLoopEnd]+'2';
LoopVar:=Pas2JSBuiltInNames[pbivnLoop];
LoopEndVar:=Pas2JSBuiltInNames[pbivnLoopEnd];
// "var $l1=1, $le2=100"
// "var $l=1, $end=100"
VS:=TJSVariableStatement(AssertElement('For init is var '+LoopEndVar,TJSVariableStatement,ForSt.Init));
VDL:=TJSVariableDeclarationList(AssertElement('For init var has comma',TJSVariableDeclarationList,VS.A));
VD:=TJSVarDeclaration(AssertElement('var '+LoopVar,TJSVarDeclaration,VDL.A));
@ -402,20 +402,20 @@ begin
AssertEquals('Correct name for '+LoopEndVar,LoopEndVar,VD.Name);
AssertLiteral('Correct end value',VD.Init,100);
// $l1<=$le2
// $l<=$end
Cond:=TJSRelationalExpressionLE(AssertElement('Condition is <= expression',TJSRelationalExpressionLE,ForSt.Cond));
AssertIdentifier('Cond LHS is '+LoopVar,Cond.A,LoopVar);
AssertIdentifier('Cond RHS is '+LoopEndVar,Cond.B,LoopEndVar);
// $l1++
// $l++
I:=TJSUnaryPostPlusPlusExpression(AssertElement('Increment is ++ statement',TJSUnaryPostPlusPlusExpression,ForSt.Incr));
AssertIdentifier('++ on correct variable name',I.A,LoopVar);
// body
L:=TJSStatementList(AssertElement('For body ist list',TJSStatementList,ForSt.Body));
// I:=$l1
A:=TJSSimpleAssignStatement(AssertElement('I:=$l1',TJSSimpleAssignStatement,L.A));
// I:=$l
A:=TJSSimpleAssignStatement(AssertElement('I:='+LoopVar,TJSSimpleAssignStatement,L.A));
AssertIdentifier('Init statement LHS is loop variable',A.LHS,'i');
AssertIdentifier('Init statement RHS is '+LoopVar,A.Expr,LoopVar);
@ -446,14 +446,14 @@ begin
F.Body:=CreateAssignStatement();
ForSt:=TJSForStatement(Convert(F,TJSForStatement));
// Should be
// for(var $l1=100, $le2=1; $l1>=$le2; $l1--){
// I=$l1;
// for(var $l=100, $end=1; $l>=$end; $l--){
// I=$l;
// a=b;
// }
LoopVar:=Pas2JSBuiltInNames[pbivnLoop]+'1';
LoopEndVar:=Pas2JSBuiltInNames[pbivnLoopEnd]+'2';
LoopVar:=Pas2JSBuiltInNames[pbivnLoop];
LoopEndVar:=Pas2JSBuiltInNames[pbivnLoopEnd];
// "var $l1=100, $le2=1"
// "var $l=100, $end=1"
VS:=TJSVariableStatement(AssertElement('For init is var '+LoopEndVar,TJSVariableStatement,ForSt.Init));
VDL:=TJSVariableDeclarationList(AssertElement('For init var has comma',TJSVariableDeclarationList,VS.A));
VD:=TJSVarDeclaration(AssertElement('var '+LoopVar,TJSVarDeclaration,VDL.A));
@ -463,20 +463,20 @@ begin
AssertEquals('Correct name for '+LoopEndVar,LoopEndVar,VD.Name);
AssertLiteral('Correct end value',VD.Init,1);
// $l1>=$le2
// $l>=$end
Cond:=TJSRelationalExpressionGE(AssertElement('Condition is >= expression',TJSRelationalExpressionGE,ForSt.Cond));
AssertIdentifier('Cond LHS is '+LoopVar,Cond.A,LoopVar);
AssertIdentifier('Cond RHS is '+LoopEndVar,Cond.B,LoopEndVar);
// $l1--
// $l--
I:=TJSUnaryPostMinusMinusExpression(AssertElement('Increment is -- statement',TJSUnaryPostMinusMinusExpression,ForSt.Incr));
AssertIdentifier('-- on correct variable name',I.A,LoopVar);
// body
L:=TJSStatementList(AssertElement('For body ist list',TJSStatementList,ForSt.Body));
// I:=$l1
A:=TJSSimpleAssignStatement(AssertElement('I:=$l1',TJSSimpleAssignStatement,L.A));
// I:=$l
A:=TJSSimpleAssignStatement(AssertElement('I:='+LoopVar,TJSSimpleAssignStatement,L.A));
AssertIdentifier('Init statement LHS is loop variable',A.LHS,'i');
AssertIdentifier('Init statement RHS is '+LoopVar,A.Expr,LoopVar);

8
packages/pastojs/tests/tcfiler.pas
View File

@ -75,7 +75,7 @@ type
procedure CheckRestoredSectionScope(const Path: string; Orig, Rest: TPas2JSSectionScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredInitialFinalizationScope(const Path: string; Orig, Rest: TPas2JSInitialFinalizationScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredEnumTypeScope(const Path: string; Orig, Rest: TPasEnumTypeScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredRecordScope(const Path: string; Orig, Rest: TPasRecordScope; Flags: TPCCheckFlags); virtual;
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 CheckRestoredScopeRefs(const Path: string; Orig, Rest: TPasScopeReferences; Flags: TPCCheckFlags); virtual;
@ -805,7 +805,7 @@ begin
end;
procedure TCustomTestPrecompile.CheckRestoredRecordScope(const Path: string;
Orig, Rest: TPasRecordScope; Flags: TPCCheckFlags);
Orig, Rest: TPas2jsRecordScope; Flags: TPCCheckFlags);
begin
CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
@ -1107,8 +1107,8 @@ begin
CheckRestoredInitialFinalizationScope(Path+'[TPas2JSInitialFinalizationScope]',TPas2JSInitialFinalizationScope(Orig),TPas2JSInitialFinalizationScope(Rest),Flags)
else if C=TPasEnumTypeScope then
CheckRestoredEnumTypeScope(Path+'[TPasEnumTypeScope]',TPasEnumTypeScope(Orig),TPasEnumTypeScope(Rest),Flags)
else if C=TPasRecordScope then
CheckRestoredRecordScope(Path+'[TPasRecordScope]',TPasRecordScope(Orig),TPasRecordScope(Rest),Flags)
else if C=TPas2jsRecordScope then
CheckRestoredRecordScope(Path+'[TPas2jsRecordScope]',TPas2jsRecordScope(Orig),TPas2jsRecordScope(Rest),Flags)
else if C=TPas2JSClassScope then
CheckRestoredClassScope(Path+'[TPas2JSClassScope]',TPas2JSClassScope(Orig),TPas2JSClassScope(Rest),Flags)
else if C=TPas2JSProcedureScope then

223
packages/pastojs/tests/tcgenerics.pas
View File

@ -16,9 +16,8 @@ type
Published
// generic record
Procedure TestGen_RecordEmpty;
Procedure TestGen_Record_ClassProc_ObjFPC;
//Procedure TestGen_Record_ClassProc_Delphi;
//Procedure TestGen_Record_ReferGenClass_DelphiFail;
Procedure TestGen_Record_ClassProc;
Procedure TestGen_Record_DelayProgram; // ToDo
// generic class
Procedure TestGen_ClassEmpty;
@ -29,20 +28,20 @@ type
Procedure TestGen_Class_TypeInfo;
Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
Procedure TestGen_Class_ClassProperty;
Procedure TestGen_Class_ClassProc_ObjFPC;
//Procedure TestGen_Class_ClassProc_Delphi;
//Procedure TestGen_Class_ReferGenClass_DelphiFail;
Procedure TestGen_Class_ClassProc;
//Procedure TestGen_Record_ReferGenClass_DelphiFail; TBird<T> = class x:TBird; end;
Procedure TestGen_Class_ClassConstructor;
// ToDo: rename local const T
Procedure TestGen_Class_TypeCastSpecializesWarn;
Procedure TestGen_Class_TypeCastSpecializesJSValueNoWarn;
procedure TestGen_Class_VarArgsOfType;
procedure TestGen_Class_OverloadsInUnit;
procedure TestGen_ClassForward_CircleRTTI;
// generic external class
procedure TestGen_ExtClass_Array;
procedure TestGen_ExtClass_GenJSValueAssign;
procedure TestGen_ExtClass_AliasMemberType;
Procedure TestGen_ExtClass_RTTI;
Procedure TestGen_ExtClass_RTTI; // ToDo: use "TGJSSET<JSValue>"
// class interfaces
procedure TestGen_ClassInterface_Corba;
@ -105,7 +104,7 @@ begin
]));
end;
procedure TTestGenerics.TestGen_Record_ClassProc_ObjFPC;
procedure TTestGenerics.TestGen_Record_ClassProc;
begin
StartProgram(false);
Add([
@ -155,6 +154,54 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_Record_DelayProgram;
begin
exit;
StartProgram(false);
Add([
'{$modeswitch AdvancedRecords}',
'type',
' generic TAnt<T> = record',
' class var x: T;',
' end;',
' TBird = record',
' b: word;',
' end;',
'var f: specialize TAnt<TBird>;',
'begin',
' f.x.b:=f.x.b+10;',
'']);
ConvertProgram;
CheckSource('TestGen_Record_DelayProgram',
LinesToStr([ // statements
'rtl.recNewS($mod, "TAnt$G1", function () {',
' this.x = $mod.TBird.$new();',
' this.$eq = function (b) {',
' return true;',
' };',
' this.$assign = function (s) {',
' return this;',
' };',
'}, true);',
'rtl.recNewT($mod, "TBird", function () {',
' this.b = 0;',
' this.$eq = function (b) {',
' return this.b === b.b;',
' };',
' this.$assign = function (s) {',
' this.b = s.b;',
' return this;',
' };',
'});',
'$mod.TAnt$G1();',
'this.f = $mod.TAnt$G1.$new();',
'']),
LinesToStr([ // $mod.$main
'$mod.f.x.b = $mod.f.x.b + 10;',
'']));
end;
procedure TTestGenerics.TestGen_ClassEmpty;
begin
StartProgram(false);
@ -408,8 +455,9 @@ begin
' p:=typeinfo(b);',
'']);
ConvertProgram;
CheckSource('TestGen_TypeInfo',
CheckSource('TestGen_Class_TypeInfo',
LinesToStr([ // statements
'$mod.$rtti.$Class("TBird$G1");',
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
@ -501,7 +549,7 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_Class_ClassProc_ObjFPC;
procedure TTestGenerics.TestGen_Class_ClassProc;
begin
StartProgram(false);
Add([
@ -772,6 +820,159 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_Class_OverloadsInUnit;
begin
StartProgram(true,[supTObject]);
AddModuleWithIntfImplSrc('UnitA.pas',
LinesToStr([
'type',
' generic TBird<T> = class',
' const c = 13;',
' constructor Create(w: T);',
' constructor Create(b: boolean);',
' end;',
'']),
LinesToStr([
'constructor TBird.Create(w: T);',
'const c = 14;',
'begin',
'end;',
'constructor TBird.Create(b: boolean);',
'const c = 15;',
'begin',
'end;',
'']));
Add([
'uses UnitA;',
'type',
' TWordBird = specialize TBird<word>;',
' TDoubleBird = specialize TBird<double>;',
'var',
' wb: TWordBird;',
' db: TDoubleBird;',
'begin',
' wb:=TWordBird.Create(3);',
' wb:=TWordBird.Create(true);',
' db:=TDoubleBird.Create(1.3);',
' db:=TDoubleBird.Create(true);',
'']);
ConvertProgram;
CheckUnit('UnitA.pas',
LinesToStr([ // statements
'rtl.module("UnitA", ["system"], function () {',
' var $mod = this;',
' rtl.createClass($mod, "TBird$G1", pas.system.TObject, function () {',
' this.c = 13;',
' var c$1 = 14;',
' this.Create$1 = function (w) {',
' return this;',
' };',
' var c$2 = 15;',
' this.Create$2 = function (b) {',
' return this;',
' };',
' });',
' rtl.createClass($mod, "TBird$G2", pas.system.TObject, function () {',
' this.c = 13;',
' var c$1 = 14;',
' this.Create$1 = function (w) {',
' return this;',
' };',
' var c$2 = 15;',
' this.Create$2 = function (b) {',
' return this;',
' };',
' });',
'});',
'']));
CheckSource('TestGen_Class_OverloadsInUnit',
LinesToStr([ // statements
'this.wb = null;',
'this.db = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.wb = pas.UnitA.TBird$G1.$create("Create$1", [3]);',
'$mod.wb = pas.UnitA.TBird$G1.$create("Create$2", [true]);',
'$mod.db = pas.UnitA.TBird$G2.$create("Create$1", [1.3]);',
'$mod.db = pas.UnitA.TBird$G2.$create("Create$2", [true]);',
'']));
end;
procedure TTestGenerics.TestGen_ClassForward_CircleRTTI;
begin
Converter.Options:=Converter.Options-[coNoTypeInfo];
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' {$M+}',
' TPersistent = class end;',
' {$M-}',
' generic TAnt<T> = class;',
' generic TFish<U> = class(TPersistent)',
' private type AliasU = U;',
' published',
' a: specialize TAnt<AliasU>;',
' end;',
' generic TAnt<T> = class(TPersistent)',
' private type AliasT = T;',
' published',
' f: specialize TFish<AliasT>;',
' end;',
'var',
' WordFish: specialize TFish<word>;',
' p: pointer;',
'begin',
' p:=typeinfo(specialize TAnt<word>);',
' p:=typeinfo(specialize TFish<word>);',
'']);
ConvertProgram;
CheckSource('TestGen_ClassForward_CircleRTTI',
LinesToStr([ // statements
'$mod.$rtti.$Class("TAnt$G2");',
'$mod.$rtti.$Class("TFish$G2");',
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
'});',
'rtl.createClass($mod, "TPersistent", $mod.TObject, function () {',
'});',
'rtl.createClass($mod, "TAnt$G2", $mod.TPersistent, function () {',
' this.$init = function () {',
' $mod.TPersistent.$init.call(this);',
' this.f = null;',
' };',
' this.$final = function () {',
' this.f = undefined;',
' $mod.TPersistent.$final.call(this);',
' };',
' var $r = this.$rtti;',
' $r.addField("f", $mod.$rtti["TFish$G2"]);',
'});',
'rtl.createClass($mod, "TFish$G2", $mod.TPersistent, function () {',
' this.$init = function () {',
' $mod.TPersistent.$init.call(this);',
' this.a = null;',
' };',
' this.$final = function () {',
' this.a = undefined;',
' $mod.TPersistent.$final.call(this);',
' };',
' var $r = this.$rtti;',
' $r.addField("a", $mod.$rtti["TAnt$G2"]);',
'});',
'this.WordFish = null;',
'this.p = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.p = $mod.$rtti["TAnt$G2"];',
'$mod.p = $mod.$rtti["TFish$G2"];',
'']));
end;
procedure TTestGenerics.TestGen_ExtClass_Array;
begin
StartProgram(false);

1071
packages/pastojs/tests/tcmodules.pas
View File

File diff suppressed because it is too large Load Diff

163
packages/pastojs/tests/tcoptimizations.pas
View File

@ -56,6 +56,18 @@ type
TTestOptimizations = class(TCustomTestOptimizations)
published
// unit optimization: aliasglobals
procedure TestOptAliasGlobals_Program;
procedure TestOptAliasGlobals_Unit; // ToDo
// ToDo: external var, const, class
// ToDo: RTTI
// ToDo: typeinfo(var), typeinfo(type)
// ToDo: resourcestring
// ToDo: Global EnumType, EnumValue, EnumType.Value, unit.EnumType.Value
// ToDo: Nested EnumType: EnumValue, EnumType.Value, unit.aType.EnumType.Value, aType.EnumType.Value, Instance.EnumType.Value
// ToDo: Instance.RecordType, Instance.RecordType.ClassVar
// ToDo: ClassVarRecord
// Whole Program Optimization
procedure TestWPO_OmitLocalVar;
procedure TestWPO_OmitLocalProc;
@ -187,6 +199,157 @@ end;
{ TTestOptimizations }
procedure TTestOptimizations.TestOptAliasGlobals_Program;
begin
AddModuleWithIntfImplSrc('UnitA.pas',
LinesToStr([
'const',
' cWidth = 17;',
'type',
' TBird = class',
' public',
' class var c: word;',
' class function Run(w: word): word; virtual; abstract;',
' end;',
' TRec = record',
' x: word;',
' end;',
'var b: TBird;',
'']),
LinesToStr([
'']));
StartProgram(true,[supTObject]);
Add([
'{$optimization AliasGlobals}',
'uses unita;',
'type',
' TEagle = class(TBird)',
' class function Run(w: word = 5): word; override;',
' end;',
'class function TEagle.Run(w: word): word;',
'begin',
'end;',
'var',
' e: TEagle;',
' r: TRec;',
'begin',
' e:=TEagle.Create;',
' b:=TBird.Create;',
' e.c:=e.c+1;',
' r.x:=TBird.c;',
' r.x:=b.c;',
' r.x:=e.Run;',
' r.x:=e.Run();',
' r.x:=e.Run(4);',
'']);
ConvertProgram;
CheckSource('TestOptAliasGlobals_Program',
LinesToStr([
'var $lmr = pas.UnitA;',
'var $ltr = $lmr.TBird;',
'var $ltr1 = $lmr.TRec;',
'rtl.createClass($mod, "TEagle", $ltr, function () {',
' this.Run = function (w) {',
' var Result = 0;',
' return Result;',
' };',
'});',
'this.e = null;',
'this.r = $ltr1.$new();',
'']),
LinesToStr([
'$mod.e = $mod.TEagle.$create("Create");',
'$lmr.b = $ltr.$create("Create");',
'$ltr.c = $mod.e.c + 1;',
'$mod.r.x = $ltr.c;',
'$mod.r.x = $lmr.b.c;',
'$mod.r.x = $mod.e.$class.Run(5);',
'$mod.r.x = $mod.e.$class.Run(5);',
'$mod.r.x = $mod.e.$class.Run(4);',
'']));
end;
procedure TTestOptimizations.TestOptAliasGlobals_Unit;
begin
exit;
AddModuleWithIntfImplSrc('UnitA.pas',
LinesToStr([
'const',
' cWidth = 17;',
'type',
' TBird = class',
' public',
' class var Span: word;',
' class procedure Fly(w: word); virtual; abstract;',
' end;',
' TRecA = record',
' x: word;',
' end;',
'var Bird: TBird;',
'']),
LinesToStr([
'']));
AddModuleWithIntfImplSrc('UnitB.pas',
LinesToStr([
'const',
' cHeight = 23;',
'type',
' TAnt = class',
' public',
' class var Legs: word;',
' class procedure Run(w: word); virtual; abstract;',
' end;',
' TRecB = record',
' y: word;',
' end;',
'var Ant: TAnt;',
'']),
LinesToStr([
'']));
StartUnit(true,[supTObject]);
Add([
'{$optimization AliasGlobals}',
'interface',
'uses unita;',
'type',
' TEagle = class(TBird)',
' class var EagleRec: TRecA;',
' class procedure Fly(w: word = 5); override;',
' end;',
'implementation',
'uses unitb;',
'type',
' TRedAnt = class(TAnt)',
' class var RedAntRecA: TRecA;',
' class var RedAntRecB: TRecB;',
' class procedure Run(w: word = 6); override;',
' end;',
'class procedure TEagle.Fly(w: word);',
'begin',
'end;',
'class procedure TRedAnt.Run(w: word);',
'begin',
'end;',
'var',
' Eagle: TEagle;',
' RedAnt: TRedAnt;',
'initialization',
' Eagle:=TEagle.Create;',
' RedAnt:=TRedAnt.Create;',
' Bird:=TBird.Create;',
' Ant:=TAnt.Create;',
' TRedAnt.RedAntRecA.x:=TRedAnt.RedAntRecB.y;',
'']);
ConvertUnit;
CheckSource('TestOptAliasGlobals_Unit',
LinesToStr([
'']),
LinesToStr([
'']));
end;
procedure TTestOptimizations.TestWPO_OmitLocalVar;
begin
StartProgram(false);

4
packages/pastojs/tests/tcsrcmap.pas
View File

@ -421,8 +421,8 @@ begin
' var Runner = 0;',
' var j = 0;',
' j = 0;',
' for (var $l1 = 3, $end2 = j; $l1 <= $end2; $l1++) {',
' Runner = $l1;',
' for (var $l = 3, $end = j; $l <= $end; $l++) {',
' Runner = $l;',
' j += 1;',
' };',
' Result = j;',

88
packages/pastojs/tests/tcunitsearch.pas
View File

@ -154,6 +154,12 @@ type
procedure TestUS_UseUnitTwiceFail;
procedure TestUS_UseUnitTwiceViaNameSpace;
// namespace
Procedure TestDefaultNameSpaceLast;
Procedure TestDefaultNameSpaceAfterNameSpace;
Procedure TestNoNameSpaceBeforeDefaultNameSpace;
Procedure TestNoNameSpaceAndDefaultNameSpace;
end;
function LinesToStr(const Lines: array of string): string;
@ -843,6 +849,88 @@ begin
Compile(['test1.pas','-FNsub','-Jc']);
end;
procedure TTestCLI_UnitSearch.TestDefaultNameSpaceLast;
begin
AddUnit('system.pp',[''],['']);
AddUnit('Unit2.pas',
['var i: longint;'],
['']);
AddUnit('NS1.Unit2.pas',
['var j: longint;'],
['']);
AddFile('test1.pas',[
'uses unIt2;',
'var',
' k: longint;',
'begin',
' k:=i;',
'end.']);
Compile(['test1.pas','','-Jc']);
end;
procedure TTestCLI_UnitSearch.TestDefaultNameSpaceAfterNameSpace;
begin
AddUnit('system.pp',[''],['']);
AddUnit('prg.Unit2.pas',
['var j: longint;'],
['']);
AddUnit('sub.Unit2.pas',
['var i: longint;'],
['']);
AddFile('prg.test1.pas',[
'uses unIt2;',
'var',
' k: longint;',
'begin',
' k:=i;',
'end.']);
Compile(['prg.test1.pas','-FNsub','-Jc']);
end;
procedure TTestCLI_UnitSearch.TestNoNameSpaceBeforeDefaultNameSpace;
begin
AddUnit('system.pp',[''],['']);
AddUnit('prg.Unit2.pas',
['var j: longint;'],
['']);
AddUnit('Unit2.pas',
['var i: longint;'],
['']);
AddFile('prg.test1.pas',[
'uses unIt2;',
'var',
' k: longint;',
'begin',
' k:=i;',
'end.']);
Compile(['prg.test1.pas','','-Jc']);
end;
procedure TTestCLI_UnitSearch.TestNoNameSpaceAndDefaultNameSpace;
begin
AddUnit('system.pp',[''],['']);
AddUnit('UnitA.pas',
['type TBool = boolean;'],
['']);
AddUnit('ThirdParty.UnitB.pas',
['uses UnitA;',
'type TAlias = TBool;'],
['']);
AddUnit('MyProject.UnitA.pas',
[
'uses ThirdParty.UnitB;',
'var a: TAlias;'],
['']);
AddFile('MyProject.Main.pas',[
'uses MyProject.UnitA;',
'var',
' b: boolean;',
'begin',
' b:=a;',
'end.']);
Compile(['MyProject.Main.pas','','-Jc']);
end;
Initialization
RegisterTests([TTestCLI_UnitSearch]);
end.

10
packages/rtl-generics/tests/testrunner.rtlgenerics.lpi
View File

@ -27,7 +27,7 @@
<CommandLineParams Value="-a --format=plain"/>
</local>
</RunParams>
<Units Count="8">
<Units Count="10">
<Unit0>
<Filename Value="testrunner.rtlgenerics.pp"/>
<IsPartOfProject Value="True"/>
@ -60,6 +60,14 @@
<Filename Value="tests.generics.dictionary.pas"/>
<IsPartOfProject Value="True"/>
</Unit7>
<Unit8>
<Filename Value="tests.generics.stack.pas"/>
<IsPartOfProject Value="True"/>
</Unit9>
<Unit9>
<Filename Value="tests.generics.queue.pas"/>
<IsPartOfProject Value="True"/>
</Unit9>
</Units>
</ProjectOptions>
<CompilerOptions>

2
packages/rtl-generics/tests/testrunner.rtlgenerics.pp
View File

@ -13,6 +13,8 @@ uses
tests.generics.trees,
tests.generics.stdcollections,
tests.generics.sets,
tests.generics.queue,
tests.generics.stack,
tests.generics.dictionary
;

388
packages/rtl-generics/tests/tests.generics.queue.pas Normal file
View File

@ -0,0 +1,388 @@
unit tests.generics.queue;
{$mode objfpc}
interface
uses
fpcunit, testregistry, Classes, SysUtils, Generics.Defaults, Generics.Collections;
Type
TMySimpleQueue = Class(Specialize TQueue<String>);
{$IFDEF FPC}
EList = EListError;
{$ENDIF}
{ TTestSimpleQueue }
TTestSimpleQueue = Class(TTestCase)
Private
FQueue : TMySimpleQueue;
FnotifyMessage : String;
FCurrentValueNotify : Integer;
FExpectValues : Array of String;
FExpectValueAction: Array of TCollectionNotification;
procedure DoAdd(aCount: Integer; aOffset: Integer=0);
procedure DoAdd2;
Procedure DoneExpectValues;
procedure DoGetValue(Match: String; ExceptionClass: TClass=nil);
procedure DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
Public
Procedure SetExpectValues(aMessage : string; AKeys : Array of String; AActions : Array of TCollectionNotification; DoReverse : Boolean = False);
Procedure SetUp; override;
Procedure TearDown; override;
Property Queue : TMySimpleQueue Read FQueue;
Published
Procedure TestEmpty;
Procedure TestAdd;
Procedure TestClear;
Procedure TestGetValue;
Procedure TestPeek;
Procedure TestDequeue;
Procedure TestToArray;
Procedure TestEnumerator;
procedure TestValueNotification;
procedure TestValueNotificationDelete;
end;
{ TMyObject }
TMyObject = Class(TObject)
Private
fOnDestroy : TNotifyEvent;
FID : Integer;
public
Constructor Create(aID : Integer; aOnDestroy : TNotifyEvent);
destructor destroy; override;
Property ID : Integer Read FID;
end;
TSingleObjectQueue = Class(Specialize TObjectQueue<TMyObject>);
{ TTestSingleObjectQueue }
TTestSingleObjectQueue = Class(TTestCase)
private
FOQueue: TSingleObjectQueue;
FList : TFPList;
procedure DoAdd(aID: Integer);
procedure DoDestroy(Sender: TObject);
Public
Procedure SetUp; override;
Procedure TearDown; override;
Property Queue : TSingleObjectQueue Read FOQueue;
Published
Procedure TestEmpty;
Procedure TestFreeOnDequeue;
Procedure TestNoFreeOnDeQueue;
end;
implementation
{ TTestSingleObjectQueue }
procedure TTestSingleObjectQueue.SetUp;
begin
FOQueue:=TSingleObjectQueue.Create(True);
FList:=TFPList.Create;
inherited SetUp;
end;
procedure TTestSingleObjectQueue.TearDown;
begin
FreeAndNil(FOQueue);
FreeAndNil(FList);
inherited TearDown;
end;
procedure TTestSingleObjectQueue.TestEmpty;
begin
AssertNotNull('Have object',Queue);
AssertEquals('Have empty object',0,Queue.Count);
end;
procedure TTestSingleObjectQueue.DoAdd(aID : Integer);
Var
O : TMyObject;
begin
O:=TMyObject.Create(aID,@DoDestroy);
FOQueue.EnQueue(O);
FList.Add(O);
end;
procedure TTestSingleObjectQueue.DoDestroy(Sender: TObject);
Var
I : Integer;
begin
I:=FList.IndexOf(Sender);
AssertTrue('Have object in Queue',I<>-1);
FList.Delete(I);
end;
procedure TTestSingleObjectQueue.TestFreeOnDeQueue;
begin
DoAdd(1);
AssertEquals('Have obj',1,FList.Count);
Queue.Dequeue;
AssertEquals('Have no obj',0,FList.Count);
end;
procedure TTestSingleObjectQueue.TestNoFreeOnDeQueue;
begin
Queue.OwnsObjects:=False;
DoAdd(1);
AssertEquals('Have obj',1,FList.Count);
Queue.DeQueue;
AssertEquals('Have obj',1,FList.Count);
end;
{ TMyObject }
constructor TMyObject.Create(aID: Integer; aOnDestroy: TNotifyEvent);
begin
FOnDestroy:=aOnDestroy;
FID:=AID;
end;
destructor TMyObject.destroy;
begin
if Assigned(FOnDestroy) then
FOnDestroy(Self);
inherited destroy;
end;
{ TTestSimpleQueue }
procedure TTestSimpleQueue.SetUp;
begin
inherited SetUp;
FQueue:=TMySimpleQueue.Create;
FCurrentValueNotify:=0;
FExpectValues:=[];
FExpectValueAction:=[];
end;
procedure TTestSimpleQueue.TearDown;
begin
// So we don't get clear messages
FQueue.OnNotify:=Nil;
FreeAndNil(FQueue);
inherited TearDown;
end;
procedure TTestSimpleQueue.TestEmpty;
begin
AssertNotNull('Have dictionary',Queue);
AssertEquals('empty dictionary',0,Queue.Count);
end;
procedure TTestSimpleQueue.DoAdd(aCount : Integer; aOffset : Integer=0);
Var
I : Integer;
begin
if aOffset=-1 then
aOffset:=Queue.Count;
For I:=aOffset+1 to aOffset+aCount do
Queue.EnQueue(IntToStr(i));
end;
procedure TTestSimpleQueue.TestAdd;
begin
DoAdd(1);
AssertEquals('Count OK',1,Queue.Count);
DoAdd(1,1);
AssertEquals('Count OK',2,Queue.Count);
end;
procedure TTestSimpleQueue.TestClear;
begin
DoAdd(3);
AssertEquals('Count OK',3,Queue.Count);
Queue.Clear;
AssertEquals('Count after clear OK',0,Queue.Count);
end;
procedure TTestSimpleQueue.DoGetValue(Match: String; ExceptionClass: TClass);
Var
EC : TClass;
A,EM : String;
begin
EC:=Nil;
try
A:=Queue.DeQueue;
except
On E : Exception do
begin
EC:=E.ClassType;
EM:=E.Message;
end
end;
if ExceptionClass=Nil then
begin
if EC<>Nil then
Fail('Got exception '+EC.ClassName+' with message: '+EM);
AssertEquals('Value is correct',Match,A)
end
else
begin
if EC=Nil then
Fail('Expected exception '+ExceptionClass.ClassName+' but got none');
if EC<>ExceptionClass then
Fail('Expected exception class '+ExceptionClass.ClassName+' but got '+EC.ClassName+' with message '+EM);
end;
end;
procedure TTestSimpleQueue.DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
begin
// Writeln(FnotifyMessage+' value Notification',FCurrentValueNotify);
AssertSame(FnotifyMessage+' value Correct sender', FQueue,aSender);
if (FCurrentValueNotify>=Length(FExpectValues)) then
Fail(FnotifyMessage+' Too many value notificiations');
AssertEquals(FnotifyMessage+' Notification value no '+IntToStr(FCurrentValueNotify),FExpectValues[FCurrentValueNotify],aItem);
Inc(FCurrentValueNotify);
end;
procedure TTestSimpleQueue.SetExpectValues(aMessage: string; AKeys: array of String;
AActions: array of TCollectionNotification; DoReverse: Boolean);
Var
I,L : integer;
begin
FnotifyMessage:=aMessage;
FCurrentValueNotify:=0;
L:=Length(aKeys);
AssertEquals('SetExpectValues: Lengths arrays equal',l,Length(aActions));
SetLength(FExpectValues,L);
SetLength(FExpectValueAction,L);
Dec(L);
if DoReverse then
For I:=0 to L do
begin
FExpectValues[L-i]:=AKeys[i];
FExpectValueAction[L-i]:=AActions[I];
end
else
For I:=0 to L do
begin
FExpectValues[i]:=AKeys[i];
FExpectValueAction[i]:=AActions[I];
end;
end;
procedure TTestSimpleQueue.TestGetValue;
Var
I : integer;
begin
DoAdd(3);
For I:=1 to 3 do
DoGetValue(IntToStr(I));
DoGetValue('4',EArgumentOutOfRangeException);
end;
procedure TTestSimpleQueue.TestPeek;
Var
I : integer;
begin
DoAdd(3);
For I:=1 to 3 do
begin
AssertEquals('Peek ',IntToStr(I),FQueue.Peek);
DoGetValue(IntToStr(I));
end;
end;
procedure TTestSimpleQueue.DoAdd2;
begin
Queue.Enqueue('A new 2');
end;
procedure TTestSimpleQueue.DoneExpectValues;
begin
AssertEquals(FnotifyMessage+' Expected number of values seen',Length(FExpectValues),FCurrentValueNotify);
end;
procedure TTestSimpleQueue.TestDequeue;
begin
DoAdd(3);
AssertEquals('1',Queue.Dequeue);
AssertEquals('Count',2,Queue.Count);
end;
procedure TTestSimpleQueue.TestToArray;
Var
A : specialize TArray<String>;
I : Integer;
SI : String;
begin
DoAdd(3);
A:=Queue.ToArray;
AssertEquals('Length Ok',3,Length(A));
For I:=1 to 3 do
begin
SI:=IntToStr(I);
AssertEquals('Value '+SI,SI,A[i-1]);
end;
end;
procedure TTestSimpleQueue.TestEnumerator;
Var
A : String;
I : Integer;
SI : String;
begin
DoAdd(3);
I:=1;
For A in Queue do
begin
SI:=IntToStr(I);
AssertEquals('Value '+SI,SI,A);
Inc(I);
end;
end;
procedure TTestSimpleQueue.TestValueNotification;
begin
Queue.OnNotify:=@DoValueNotify;
SetExpectValues('Add',['1','2','3'],[cnAdded,cnAdded,cnAdded]);
DoAdd(3);
DoneExpectValues;
end;
procedure TTestSimpleQueue.TestValueNotificationDelete;
begin
DoAdd(3);
Queue.OnNotify:=@DoValueNotify;
SetExpectValues('Clear',['1','2','3'],[cnRemoved,cnRemoved,cnRemoved],{$IFDEF FPC}true{$ELSE}False{$endif});
Queue.Clear;
DoneExpectValues;
end;
begin
RegisterTests([ TTestSimpleQueue,TTestSingleObjectQueue]);
end.

403
packages/rtl-generics/tests/tests.generics.stack.pas Normal file
View File

@ -0,0 +1,403 @@
unit tests.generics.stack;
{$mode objfpc}
interface
uses
fpcunit, testregistry, Classes, SysUtils, Generics.Defaults, Generics.Collections;
Type
TMySimpleStack = Class(Specialize TStack<String>);
{$IFDEF FPC}
EList = EListError;
{$ENDIF}
{ TTestSimpleStack }
TTestSimpleStack = Class(TTestCase)
Private
FStack : TMySimpleStack;
FnotifyMessage : String;
FCurrentValueNotify : Integer;
FExpectValues : Array of String;
FExpectValueAction: Array of TCollectionNotification;
procedure DoAdd(aCount: Integer);
procedure DoAdd2;
Procedure DoneExpectValues;
procedure DoGetValue(Match: String; ExceptionClass: TClass=nil);
procedure DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
Public
Procedure SetExpectValues(aMessage : string; AKeys : Array of String; AActions : Array of TCollectionNotification; DoReverse : Boolean = False);
Procedure SetUp; override;
Procedure TearDown; override;
Property Stack : TMySimpleStack Read FStack;
Published
Procedure TestEmpty;
Procedure TestAdd;
Procedure TestClear;
Procedure TestGetValue;
Procedure TestPeek;
Procedure TestPop;
Procedure TestToArray;
Procedure TestEnumerator;
procedure TestValueNotification;
procedure TestValueNotificationDelete;
end;
{ TMyObject }
TMyObject = Class(TObject)
Private
fOnDestroy : TNotifyEvent;
FID : Integer;
public
Constructor Create(aID : Integer; aOnDestroy : TNotifyEvent);
destructor destroy; override;
Property ID : Integer Read FID;
end;
TSingleObjectStack = Class(Specialize TObjectStack<TMyObject>);
{ TTestSingleObjectStack }
TTestSingleObjectStack = Class(TTestCase)
private
FOStack: TSingleObjectStack;
FList : TFPList;
procedure DoAdd(aID: Integer);
procedure DoDestroy(Sender: TObject);
Public
Procedure SetUp; override;
Procedure TearDown; override;
Property Stack : TSingleObjectStack Read FOStack;
Published
Procedure TestEmpty;
Procedure TestFreeOnPop;
Procedure TestNoFreeOnPop;
end;
implementation
{ TTestSingleObjectStack }
procedure TTestSingleObjectStack.SetUp;
begin
FOStack:=TSingleObjectStack.Create(True);
FList:=TFPList.Create;
inherited SetUp;
end;
procedure TTestSingleObjectStack.TearDown;
Var
I : integer;
A : TObject;
begin
FreeAndNil(FOStack);
for I:=0 to FList.Count-1 do
begin
A:=TObject(FList[i]);
A.Free;
end;
FreeAndNil(FList);
inherited TearDown;
end;
procedure TTestSingleObjectStack.TestEmpty;
begin
AssertNotNull('Have object',Stack);
AssertEquals('Have empty object',0,Stack.Count);
end;
procedure TTestSingleObjectStack.DoAdd(aID : Integer);
Var
O : TMyObject;
begin
O:=TMyObject.Create(aID,@DoDestroy);
FOStack.Push(O);
FList.Add(O);
end;
procedure TTestSingleObjectStack.DoDestroy(Sender: TObject);
Var
I : Integer;
begin
I:=FList.IndexOf(Sender);
AssertTrue('Have object in Stack',I<>-1);
FList.Delete(I);
end;
procedure TTestSingleObjectStack.TestFreeOnPop;
begin
DoAdd(1);
AssertEquals('Have obj',1,FList.Count);
Stack.Pop;
AssertEquals('Have no obj',0,FList.Count);
end;
procedure TTestSingleObjectStack.TestNoFreeOnPop;
begin
Stack.OwnsObjects:=False;
DoAdd(1);
AssertEquals('Have obj',1,FList.Count);
Stack.Pop;
AssertEquals('Have obj',1,FList.Count);
end;
{ TMyObject }
constructor TMyObject.Create(aID: Integer; aOnDestroy: TNotifyEvent);
begin
FOnDestroy:=aOnDestroy;
FID:=AID;
end;
destructor TMyObject.destroy;
begin
if Assigned(FOnDestroy) then
FOnDestroy(Self);
inherited destroy;
end;
{ TTestSimpleStack }
procedure TTestSimpleStack.SetUp;
begin
inherited SetUp;
FStack:=TMySimpleStack.Create;
FCurrentValueNotify:=0;
FExpectValues:=[];
FExpectValueAction:=[];
end;
procedure TTestSimpleStack.TearDown;
begin
// So we don't get clear messages
FStack.OnNotify:=Nil;
FreeAndNil(FStack);
inherited TearDown;
end;
procedure TTestSimpleStack.TestEmpty;
begin
AssertNotNull('Have dictionary',Stack);
AssertEquals('empty dictionary',0,Stack.Count);
end;
procedure TTestSimpleStack.DoAdd(aCount : Integer);
Var
I : Integer;
begin
For I:=1 to aCount do
Stack.Push(IntToStr(i));
end;
procedure TTestSimpleStack.TestAdd;
begin
DoAdd(1);
AssertEquals('Count OK',1,Stack.Count);
DoAdd(1);
AssertEquals('Count OK',2,Stack.Count);
end;
procedure TTestSimpleStack.TestClear;
begin
DoAdd(3);
AssertEquals('Count OK',3,Stack.Count);
Stack.Clear;
AssertEquals('Count after clear OK',0,Stack.Count);
end;
procedure TTestSimpleStack.DoGetValue(Match: String; ExceptionClass: TClass);
Var
EC : TClass;
A,EM : String;
begin
EC:=Nil;
try
A:=Stack.Pop;
except
On E : Exception do
begin
EC:=E.ClassType;
EM:=E.Message;
end
end;
if ExceptionClass=Nil then
begin
if EC<>Nil then
Fail('Got exception '+EC.ClassName+' with message: '+EM);
AssertEquals('Value is correct',Match,A)
end
else
begin
if EC=Nil then
Fail('Expected exception '+ExceptionClass.ClassName+' but got none');
if EC<>ExceptionClass then
Fail('Expected exception class '+ExceptionClass.ClassName+' but got '+EC.ClassName+' with message '+EM);
end;
end;
procedure TTestSimpleStack.DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
begin
// Writeln(FnotifyMessage+' value Notification',FCurrentValueNotify);
AssertSame(FnotifyMessage+' value Correct sender', FStack,aSender);
if (FCurrentValueNotify>=Length(FExpectValues)) then
Fail(FnotifyMessage+' Too many value notificiations');
AssertEquals(FnotifyMessage+' Notification value no '+IntToStr(FCurrentValueNotify),FExpectValues[FCurrentValueNotify],aItem);
Inc(FCurrentValueNotify);
end;
procedure TTestSimpleStack.SetExpectValues(aMessage: string; AKeys: array of String;
AActions: array of TCollectionNotification; DoReverse: Boolean);
Var
I,L : integer;
begin
FnotifyMessage:=aMessage;
FCurrentValueNotify:=0;
L:=Length(aKeys);
AssertEquals('SetExpectValues: Lengths arrays equal',l,Length(aActions));
SetLength(FExpectValues,L);
SetLength(FExpectValueAction,L);
Dec(L);
if DoReverse then
For I:=0 to L do
begin
FExpectValues[L-i]:=AKeys[i];
FExpectValueAction[L-i]:=AActions[I];
end
else
For I:=0 to L do
begin
FExpectValues[i]:=AKeys[i];
FExpectValueAction[i]:=AActions[I];
end;
end;
procedure TTestSimpleStack.TestGetValue;
Var
I : integer;
begin
DoAdd(3);
For I:=3 downto 1 do
DoGetValue(IntToStr(I));
DoGetValue('4',EArgumentOutOfRangeException);
end;
procedure TTestSimpleStack.TestPeek;
Var
I : integer;
begin
DoAdd(3);
For I:=3 downto 1 do
begin
AssertEquals('Peek ',IntToStr(I),FStack.Peek);
DoGetValue(IntToStr(I));
end;
end;
procedure TTestSimpleStack.DoAdd2;
begin
Stack.Push('A new 2');
end;
procedure TTestSimpleStack.DoneExpectValues;
begin
AssertEquals(FnotifyMessage+' Expected number of values seen',Length(FExpectValues),FCurrentValueNotify);
end;
procedure TTestSimpleStack.TestPop;
Var
I : Integer;
SI : String;
begin
DoAdd(3);
For I:=3 downto 1 do
begin
SI:=IntToStr(I);
AssertEquals('Value '+SI,SI,FStack.Pop);
end;
AssertEquals('Count',0,Stack.Count);
end;
procedure TTestSimpleStack.TestToArray;
Var
A : specialize TArray<String>;
I : Integer;
SI : String;
begin
DoAdd(3);
A:=Stack.ToArray;
AssertEquals('Length Ok',3,Length(A));
For I:=1 to 3 do
begin
SI:=IntToStr(I);
AssertEquals('Value '+SI,SI,A[i-1]);
end;
end;
procedure TTestSimpleStack.TestEnumerator;
Var
A : String;
I : Integer;
SI : String;
begin
DoAdd(3);
I:=1;
For A in Stack do
begin
SI:=IntToStr(i);
AssertEquals('Value '+SI,SI,A);
Inc(I);
end;
end;
procedure TTestSimpleStack.TestValueNotification;
begin
Stack.OnNotify:=@DoValueNotify;
SetExpectValues('Add',['1','2','3'],[cnAdded,cnAdded,cnAdded]);
DoAdd(3);
DoneExpectValues;
end;
procedure TTestSimpleStack.TestValueNotificationDelete;
begin
DoAdd(3);
Stack.OnNotify:=@DoValueNotify;
SetExpectValues('Clear',['3','2','1'],[cnRemoved,cnRemoved,cnRemoved],False);
Stack.Clear;
DoneExpectValues;
end;
begin
RegisterTests([ TTestSimpleStack,TTestSingleObjectStack]);
end.

58
utils/pas2js/dist/rtl.js vendored
View File

@ -347,19 +347,33 @@ var rtl = {
// Create a class using an external ancestor.
// If newinstancefnname is given, use that function to create the new object.
// If exist call BeforeDestruction and AfterConstruction.
var c = Object.create(ancestor);
var isFunc = rtl.isFunction(ancestor);
var c = null;
if (isFunc){
// create pascal class descendent from JS function
c = Object.create(ancestor.prototype);
} else if (ancestor.$func){
// create pascal class descendent from a pascal class descendent of a JS function
isFunc = true;
c = Object.create(ancestor);
c.$ancestor = ancestor;
} else {
c = Object.create(ancestor);
}
c.$create = function(fn,args){
if (args == undefined) args = [];
var o = null;
if (newinstancefnname.length>0){
o = this[newinstancefnname](fn,args);
} else if(isFunc) {
o = new this.$func(args);
} else {
o = Object.create(this);
o = Object.create(c);
}
if (o.$init) o.$init();
try{
if (typeof(fn)==="string"){
o[fn].apply(o,args);
this[fn].apply(o,args);
} else {
fn.apply(o,args);
};
@ -367,7 +381,7 @@ var rtl = {
} catch($e){
// do not call BeforeDestruction
if (o.Destroy) o.Destroy();
if (o.$final) this.$final();
if (o.$final) o.$final();
throw $e;
}
return o;
@ -378,6 +392,11 @@ var rtl = {
if (this.$final) this.$final();
};
rtl.initClass(c,parent,name,initfn);
if (isFunc){
function f(){}
f.prototype = c;
c.$func = f;
}
},
createHelper: function(parent,name,ancestor,initfn){
@ -432,29 +451,34 @@ var rtl = {
// create new record type
var t = {};
if (parent) parent[name] = t;
function hide(prop){
Object.defineProperty(t,prop,{enumerable:false});
}
var h = rtl.hideProp;
if (full){
rtl.initStruct(t,parent,name);
t.$record = t;
hide('$record');
hide('$name');
hide('$parent');
hide('$module');
h(t,'$record');
h(t,'$name');
h(t,'$parent');
h(t,'$module');
}
initfn.call(t);
if (!t.$new){
t.$new = function(){ return Object.create(this); };
t.$new = function(){ return Object.create(t); };
}
t.$clone = function(r){ return this.$new().$assign(r); };
hide('$new');
hide('$clone');
hide('$eq');
hide('$assign');
t.$clone = function(r){ return t.$new().$assign(r); };
h(t,'$new');
h(t,'$clone');
h(t,'$eq');
h(t,'$assign');
return t;
},
recNewS: function(parent,name,initfn,full){
// register specialized record type
parent[name] = function(){
rtl.recNewT(parent,name,initfn,full);
}
},
is: function(instance,type){
return type.isPrototypeOf(instance) || (instance===type);
},