paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 18:29:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

pastojs: filer: class forward

Browse Source 
git-svn-id: trunk@47153 -
This commit is contained in:
Mattias Gaertner 2020-10-22 20:07:02 +00:00
parent 6fc930a0fc
commit 993c511554
3 changed files with 170 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -18465,7 +18465,7 @@ begin
aResolver:=AContext.Resolver;
Proc:=TPasProcedure(ResolvedEl.IdentEl);
if not (Proc.Parent is TPasMembersType)
if (not (Proc.Parent is TPasMembersType))
or (ptmStatic in Proc.ProcType.Modifiers) then
begin
// not an "of object" method -> simply use the function

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

@ -1028,10 +1028,11 @@ type
protected
// specialize
FPendingSpecialize: TPCUReaderPendingSpecialized; // chain of TPCUReaderPendingSpecialized
function FindPendingSpecialize(Id: integer): TPCUReaderPendingSpecialized;
function AddPendingSpecialize(Id: integer; const SpecName: string): TPCUReaderPendingSpecialized;
function CreateSpecializedElement(PendSpec: TPCUReaderPendingSpecialized): boolean; // false=param missing
function CreateSpecializedElement(PendSpec: TPCUReaderPendingSpecialized): boolean; // false=param missing, Note: needs ResolvePendingIdentifierScopes
procedure DeletePendingSpecialize(PendSpec: TPCUReaderPendingSpecialized);
procedure PromiseSpecialize(SpecId: integer; El: TPasElement; const SpecName: string); virtual;
function PromiseSpecialize(SpecId: integer; const SpecName: string; RefEl, ErrorEl: TPasElement): TPCUReaderPendingSpecialized; virtual;
procedure ResolveSpecializedElements(Complete: boolean);
protected
// json
@ -5418,9 +5419,20 @@ begin
RaiseMsg(20200514130809,SpecData.Element,GetObjPath(RefEl));
end;
function TPCUReader.FindPendingSpecialize(Id: integer
): TPCUReaderPendingSpecialized;
begin
Result:=FPendingSpecialize;
while (Result<>nil) and (Result.Id<>Id) do
Result:=Result.Next;
end;
function TPCUReader.AddPendingSpecialize(Id: integer; const SpecName: string
): TPCUReaderPendingSpecialized;
begin
if FindPendingSpecialize(Id)<>nil then
RaiseMsg(20201022214051,SpecName+'='+IntToStr(Id));
Result:=TPCUReaderPendingSpecialized.Create;
if FPendingSpecialize<>nil then
begin
@ -5444,21 +5456,26 @@ var
GenericEl: TPasGenericType;
begin
Result:=false;
{$IFDEF VerbosePCUFiler}
writeln('TPCUReader.CreateSpecializedElement Gen=',GetObjPath(PendSpec.GenericEl));
{$ENDIF}
if PendSpec.RefEl=nil then
begin
if PendSpec.GenericEl=nil then
RaiseMsg(20200531101241,PendSpec.SpecName)
else
RaiseMsg(20200531101105,PendSpec.GenericEl);// nothing uses this specialize
RaiseMsg(20200531101105,PendSpec.GenericEl,PendSpec.SpecName);// nothing uses this specialize
end;
if PendSpec.GenericEl=nil then
RaiseMsg(20200531101333,PendSpec.RefEl);
RaiseMsg(20200531101333,PendSpec.RefEl,PendSpec.SpecName);
Obj:=PendSpec.Obj;
if Obj=nil then
RaiseMsg(20200531101128,PendSpec.GenericEl); // specialize missing in JSON
RaiseMsg(20200531101128,PendSpec.GenericEl,PendSpec.SpecName); // specialize missing in JSON
// resolve params
RefParams:=PendSpec.Params;
if RefParams=nil then
RaiseMsg(20201022215141,PendSpec.GenericEl,PendSpec.SpecName);
for i:=0 to RefParams.Count-1 do
begin
Param:=TPCUReaderPendingSpecializedParam(RefParams[i]);
@ -5501,25 +5518,18 @@ begin
PendSpec.Free;
end;
procedure TPCUReader.PromiseSpecialize(SpecId: integer; El: TPasElement;
const SpecName: string);
var
PendSpec: TPCUReaderPendingSpecialized;
function TPCUReader.PromiseSpecialize(SpecId: integer; const SpecName: string;
RefEl, ErrorEl: TPasElement): TPCUReaderPendingSpecialized;
begin
PendSpec:=FPendingSpecialize;
while PendSpec<>nil do
begin
if PendSpec.Id=SpecId then
break;
PendSpec:=PendSpec.Next;
end;
Result:=FindPendingSpecialize(SpecId);
if Result=nil then
Result:=AddPendingSpecialize(SpecId,SpecName)
else if Result.SpecName<>SpecName then
RaiseMsg(20200531093342,ErrorEl,'Id='+IntToStr(SpecId)+' Expected SpecName "'+SpecName+'", but was "'+Result.SpecName+'"');
if PendSpec=nil then
PendSpec:=AddPendingSpecialize(SpecId,SpecName)
else if PendSpec.SpecName<>SpecName then
RaiseMsg(20200531093342,El,'Id='+IntToStr(SpecId)+' Expected SpecName "'+SpecName+'", but was "'+PendSpec.SpecName+'"');
if PendSpec.RefEl=nil then
PendSpec.RefEl:=El;
if Result.RefEl=nil then
Result.RefEl:=RefEl;
// Note: cannot specialize before ResolvePendingIdentifierScopes;
end;
procedure TPCUReader.ResolveSpecializedElements(Complete: boolean);
@ -5541,7 +5551,7 @@ begin
if Ref<>nil then
PendSpec.RefEl:=GetReferrerEl(Ref.Pending);
end;
if PendSpec.RefEl<>nil then
if (PendSpec.RefEl<>nil) and (PendSpec.GenericEl<>nil) then
begin
if CreateSpecializedElement(PendSpec) then
Changed:=true
@ -5554,8 +5564,20 @@ begin
if Complete then
UnresolvedSpec:=FPendingSpecialize;
if UnresolvedSpec<>nil then
begin
{$IF defined(VerbosePJUFiler) or defined(VerbosePas2JS)}
PendSpec:=FPendingSpecialize;
while PendSpec<>nil do
begin
{AllowWriteln}
writeln('TPCUReader.ResolveSpecializedElements PENDING: ',PendSpec.SpecName+' Id='+IntToStr(PendSpec.Id)+' RefEl='+GetObjPath(PendSpec.RefEl)+' GenericEl='+GetObjPath(PendSpec.GenericEl));;
{AllowWriteln-}
PendSpec:=PendSpec.Next;
end;
{$ENDIF}
// a pending specialize cannot resolve its params
RaiseMsg(20200531101924,UnresolvedSpec.GenericEl,UnresolvedSpec.SpecName+' Id='+IntToStr(UnresolvedSpec.Id)+' RefEl='+GetObjPath(UnresolvedSpec.RefEl));
RaiseMsg(20200531101924,UnresolvedSpec.GenericEl,UnresolvedSpec.SpecName+' Id='+IntToStr(UnresolvedSpec.Id)+' RefEl='+GetObjPath(UnresolvedSpec.RefEl)+' GenericEl='+GetObjPath(UnresolvedSpec.GenericEl));
end;
end;
procedure TPCUReader.RaiseMsg(Id: int64; const Msg: string);
@ -6575,7 +6597,7 @@ begin
if not ReadString(Obj,'SpecName',SpecName,GenEl) then
RaiseMsg(20200531085133,GenEl);
PendSpec:=AddPendingSpecialize(Id,SpecName);
PendSpec:=PromiseSpecialize(Id,SpecName,nil,GenEl);
PendSpec.Obj:=Obj;
PendSpec.GenericEl:=GenEl;
@ -6596,6 +6618,11 @@ begin
PendParam.Index:=i;
PendParam.Id:=Id;
end;
{$IFDEF VerbosePCUFiler}
writeln('TPCUReader.ReadSpecialization Id=',PendSpec.Id,' GenEl=',GetObjPath(PendSpec.GenericEl),' SpecName=',PendSpec.SpecName,' ElRef=',GetObjPath(PendSpec.RefEl));
{$ENDIF}
// Note: cannot specialize before ResolvePendingIdentifierScopes;
end;
procedure TPCUReader.ReadExternalReferences(Obj: TJSONObject; El: TPasElement);
@ -8121,7 +8148,7 @@ procedure TPCUReader.ReadSpecializeType(Obj: TJSONObject;
var
GenType: TPasGenericType;
GenericTemplateTypes: TFPList;
ExpName: string;
SpecName: string;
i, SpecId: Integer;
Data: TPasSpecializeTypeData;
begin
@ -8153,12 +8180,12 @@ begin
PromiseSetElReference(SpecId,@Set_SpecializeTypeData,Data,El);
// check old specialized name
if not ReadString(Obj,'SpecName',ExpName,El) then
if not ReadString(Obj,'SpecName',SpecName,El) then
RaiseMsg(20200219122919,El);
if ExpName='' then
if SpecName='' then
RaiseMsg(20200530134152,El);
PromiseSpecialize(SpecId,El,ExpName);
PromiseSpecialize(SpecId,SpecName,El,El);
end;
procedure TPCUReader.ReadInlineSpecializeExpr(Obj: TJSONObject;

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

@ -84,6 +84,8 @@ type
procedure CheckRestoredRecordScope(const Path: string; Orig, Rest: TPas2jsRecordScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredClassScope(const Path: string; Orig, Rest: TPas2JSClassScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredProcScope(const Path: string; Orig, Rest: TPas2JSProcedureScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredProcTypeScope(const Path: string; Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredArrayScope(const Path: string; Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredPrecompiledJS(const Path: string; OrigEl: TPasElement; Orig: TPas2JSPrecompiledJS; RestEl: TPasElement; Rest: TPas2JSPrecompiledJS; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredScopeRefs(const Path: string; Orig, Rest: TPasScopeReferences; Flags: TPCCheckFlags); virtual;
procedure CheckRestoredPropertyScope(const Path: string; Orig, Rest: TPasPropertyScope; Flags: TPCCheckFlags); virtual;
@ -218,13 +220,11 @@ type
procedure TestPC_GenericFunction_AnonymousProc;
procedure TestPC_GenericClass;
procedure TestPC_GenericMethod;
// ToDo: GenericMethod Calls, ProcTypes
procedure TestPC_SpecializeClassSameUnit;
procedure TestPC_Specialize_LocalTypeInUnit;
// ToDo: specialize local generic type via class forward
// ToDo: inline specialize local generic type in unit interface
// ToDo: inline specialize local generic type in unit implementation
// ToDo: inline specialize local generic type in proc decl
// ToDo: inline specialize local generic type in proc body
procedure TestPC_Specialize_ClassForward;
procedure TestPC_InlineSpecialize_LocalTypeInUnit;
// ToDo: specialize extern generic type in unit interface
// ToDo: specialize extern generic type in unit implementation
// ToDo: specialize extern generic type in proc decl
@ -920,6 +920,8 @@ procedure TCustomTestPrecompile.CheckRestoredRecordScope(const Path: string;
begin
CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredClassScope(const Path: string;
@ -993,6 +995,9 @@ begin
end;
CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredProcScope(const Path: string;
@ -1029,6 +1034,29 @@ begin
begin
// ImplProc
end;
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredProcTypeScope(const Path: string;
Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags);
begin
if Path='' then ;
if Flags=[] then ;
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredArrayScope(const Path: string;
Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags);
begin
if Path='' then ;
if Flags=[] then ;
// ok -> use same JSName
Rest.JSName:=Orig.JSName;
end;
procedure TCustomTestPrecompile.CheckRestoredPrecompiledJS(const Path: string;
@ -1255,6 +1283,10 @@ begin
CheckRestoredClassScope(Path+'[TPas2JSClassScope]',TPas2JSClassScope(Orig),TPas2JSClassScope(Rest),Flags)
else if C=TPas2JSProcedureScope then
CheckRestoredProcScope(Path+'[TPas2JSProcedureScope]',TPas2JSProcedureScope(Orig),TPas2JSProcedureScope(Rest),Flags)
else if C=TPas2JSArrayScope then
CheckRestoredArrayScope(Path+'[TPas2JSArrayScope]',TPas2JSArrayScope(Orig),TPas2JSArrayScope(Rest),Flags)
else if C=TPas2JSProcTypeScope then
CheckRestoredProcTypeScope(Path+'[TPas2JSProcTypeScope]',TPas2JSProcTypeScope(Orig),TPas2JSProcTypeScope(Rest),Flags)
else if C=TPasPropertyScope then
CheckRestoredPropertyScope(Path+'[TPasPropertyScope]',TPasPropertyScope(Orig),TPasPropertyScope(Rest),Flags)
else if C=TPasGenericParamsScope then
@ -3280,19 +3312,89 @@ begin
'type',
' TWordBird = TBird<word>;',
'procedure Run;',
//'type TShortIntBird = TBird<shortint>;',
'type TShortIntBird = TBird<shortint>;',
'var',
//' shb: TShortIntBird;',
' shb: TShortIntBird;',
' wb: TWordBird;',
'begin',
//' shb.a:=3;',
' shb.a:=3;',
' wb.a:=4;',
'end;',
'procedure Fly;',
//'type TByteBird = TBird<byte>;',
//'var bb: TByteBird;',
'type TByteBird = TBird<byte>;',
'var bb: TByteBird;',
'begin',
//' bb.a:=5;',
' bb.a:=5;',
' Run;',
'end;',
'begin',
'']);
WriteReadUnit;
end;
procedure TTestPrecompile.TestPC_Specialize_ClassForward;
begin
StartUnit(false);
Add([
'{$mode delphi}',
'interface',
'type',
' TObject = class',
' end;',
' TBird<T> = class;',
' TAnt = class',
' b: TBird<word>;',
' end;',
' TBird<T> = class',
' a: TAnt;',
' end;',
'procedure Fly;',
'implementation',
'procedure Fly;',
'var b: TBird<Double>;',
'begin',
' b.a:=nil;',
'end;',
'begin',
'']);
WriteReadUnit;
end;
procedure TTestPrecompile.TestPC_InlineSpecialize_LocalTypeInUnit;
begin
StartUnit(false);
Add([
'{$mode delphi}',
'interface',
'type',
' TObject = class',
' constructor Create;',
' end;',
' TBird<T> = class',
' a: T;',
' end;',
'var',
' db: TBIrd<double>;',
'procedure Fly;',
'implementation',
'constructor TObject.Create;',
'begin',
'end;',
'var wb: TBird<word>;',
'procedure Run;',
'var',
' shb: TBird<shortint>;',
' bb: TBird<boolean>;',
'begin',
' shb.a:=3;',
' wb.a:=4;',
' bb.a:=true;',
' TBird<string>.Create;',
'end;',
'procedure Fly;',
'var lb: TBird<longint>;',
'begin',
' lb.a:=5;',
' Run;',
'end;',
'begin',