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

pas2js: fixed delay init specializations after loading impl sections

Browse Source 
git-svn-id: trunk@49226 -
This commit is contained in:
Mattias Gaertner 2021-04-18 12:51:54 +00:00
parent fe78829b99
commit 1861dc83d9
3 changed files with 111 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2082,8 +2082,8 @@ type
Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); virtual;
Procedure AddHeaderStatement(JS: TJSElement; PosEl: TPasElement; aContext: TConvertContext); virtual;
Procedure AddImplHeaderStatement(JS: TJSElement; PosEl: TPasElement; aContext: TConvertContext); virtual;
Procedure AddDelayedInits(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); virtual;
Procedure AddDelaySpecializeInit(El: TPasGenericType; Src: TJSSourceElements; AContext: TConvertContext); virtual;
function AddDelayedInits(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext): boolean; virtual;
function CreateDelaySpecializeInit(El: TPasGenericType; AContext: TConvertContext): TJSElement; virtual;
// enum and sets
Function CreateReferencedSet(El: TPasElement; SetExpr: TJSElement): TJSElement; virtual;
// record
@ -8199,7 +8199,7 @@ Var
ModuleName, ModVarName: String;
IntfContext: TSectionContext;
ImplVarSt: TJSVariableStatement;
HasImplUsesClause, ok, NeedRTLCheckVersion: Boolean;
HasImplCode, ok, NeedRTLCheckVersion: Boolean;
Prg: TPasProgram;
Lib: TPasLibrary;
ImplFuncAssignSt: TJSSimpleAssignStatement;
@ -8280,7 +8280,7 @@ begin
Prg:=TPasProgram(El);
if Assigned(Prg.ProgramSection) then
AddToSourceElements(Src,ConvertDeclarations(Prg.ProgramSection,IntfContext));
AddDelayedInits(Prg,Src,IntfContext);
HasImplCode:=AddDelayedInits(Prg,Src,IntfContext);
CreateInitSection(Prg,Src,IntfContext);
end
else if El is TPasLibrary then
@ -8288,7 +8288,7 @@ begin
Lib:=TPasLibrary(El);
if Assigned(Lib.LibrarySection) then
AddToSourceElements(Src,ConvertDeclarations(Lib.LibrarySection,IntfContext));
AddDelayedInits(Lib,Src,IntfContext);
HasImplCode:=AddDelayedInits(Lib,Src,IntfContext);
CreateInitSection(Lib,Src,IntfContext);
// ToDo: append exports
end
@ -8317,7 +8317,9 @@ begin
// append initialization section
CreateInitSection(El,Src,IntfSecCtx);
if TJSSourceElements(ImplFunc.AFunction.Body.A).Statements.Count=0 then
if TJSSourceElements(ImplFunc.AFunction.Body.A).Statements.Count>0 then
HasImplCode:=true
else
begin
// empty implementation
@ -8325,18 +8327,14 @@ begin
RemoveFromSourceElements(Src,ImplVarSt);
// remove unneeded $mod.$implcode = function(){}
RemoveFromSourceElements(Src,ImplFuncAssignSt);
HasImplUsesClause:=(El.ImplementationSection<>nil)
// keep impl uses section
HasImplCode:=(El.ImplementationSection<>nil)
and (length(El.ImplementationSection.UsesClause)>0);
end
else
begin
HasImplUsesClause:=true;
end;
if HasImplUsesClause then
if HasImplCode then
// add implementation uses list: [<implementation uses1>,<uses2>, ...]
ArgArray.AddElement(CreateUsesList(El.ImplementationSection,AContext));
end; // end unit
if (ModScope<>nil) and (coStoreImplJS in Options) then
@ -17846,13 +17844,18 @@ begin
IntfSec.AddImplHeaderStatement(JS);
end;
procedure TPasToJSConverter.AddDelayedInits(El: TPasModule;
Src: TJSSourceElements; AContext: TConvertContext);
function TPasToJSConverter.AddDelayedInits(El: TPasModule;
Src: TJSSourceElements; AContext: TConvertContext): boolean;
var
aResolver: TPas2JSResolver;
Hub: TPas2JSResolverHub;
i: Integer;
JS: TJSElement;
AssignSt: TJSSimpleAssignStatement;
FunDecl: TJSFunctionDeclarationStatement;
ImplSrc: TJSSourceElements;
begin
Result:=false;
aResolver:=AContext.Resolver;
if aResolver=nil then exit;
if El=nil then ;
@ -17860,12 +17863,29 @@ begin
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.AddDelayedInits Hub.JSDelaySpecializeCount=',Hub.JSDelaySpecializeCount);
{$ENDIF}
ImplSrc:=nil;
for i:=0 to Hub.JSDelaySpecializeCount-1 do
AddDelaySpecializeInit(Hub.JSDelaySpecializes[i],Src,AContext);
begin
JS:=CreateDelaySpecializeInit(Hub.JSDelaySpecializes[i],AContext);
if JS=nil then continue;
if ImplSrc=nil then
begin
// create "$mod.$implcode = function(){ }"
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
AddToSourceElements(Src,AssignSt);
AssignSt.LHS:=CreateMemberExpression([GetBIName(pbivnModule),GetBIName(pbivnImplCode)]);
// create function(){}
FunDecl:=CreateFunctionSt(El,true,true);
AssignSt.Expr:=FunDecl;
ImplSrc:=TJSSourceElements(FunDecl.AFunction.Body.A);
end;
AddToSourceElements(ImplSrc,JS);
Result:=true;
end;
end;
procedure TPasToJSConverter.AddDelaySpecializeInit(El: TPasGenericType;
Src: TJSSourceElements; AContext: TConvertContext);
function TPasToJSConverter.CreateDelaySpecializeInit(El: TPasGenericType;
AContext: TConvertContext): TJSElement;
var
C: TClass;
Path: String;
@ -17876,6 +17896,7 @@ var
ElTypeHi, ElTypeLo: TPasType;
aResolver: TPas2JSResolver;
begin
Result:=nil;
if not IsElementUsed(El) then exit;
if not AContext.Resolver.IsFullySpecialized(El) then
RaiseNotSupported(El,AContext,20201202145045,'not fully specialized, probably a bug in the analyzer');
@ -17889,7 +17910,7 @@ begin
Path:=CreateReferencePath(El,AContext,rpkPathAndName)+'.'+GetBIName(pbifnClassInitSpecialize);
Call:=CreateCallExpression(El);
Call.Expr:=CreatePrimitiveDotExpr(Path,El);
AddToSourceElements(Src,Call);
Result:=Call;
end
else if (C=TPasProcedureType) or (C=TPasFunctionType) then
begin
@ -17901,7 +17922,7 @@ begin
DotExpr.Name:=TJSString(GetBIName(pbivnRTTIProc_InitSpec));
Call:=CreateCallExpression(El);
Call.Expr:=DotExpr;
AddToSourceElements(Src,Call);
Result:=Call;
end
else if (C=TPasArrayType) then
begin
@ -17928,7 +17949,7 @@ begin
AssignSt.LHS:=CreateDotNameExpr(El,CreateTypeInfoRef(El,AContext,El),
TJSString(GetBIName(pbivnRTTIArray_ElType)));
AssignSt.Expr:=CreateTypeInfoRef(ElTypeHi,AContext,El);
AddToSourceElements(Src,AssignSt);
Result:=AssignSt;
end
else
RaiseNotSupported(El,AContext,20200831115251);

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

@ -20,7 +20,7 @@ type
Procedure TestGen_Record_ClassVarRecord_Program;
Procedure TestGen_Record_ClassVarRecord_UnitImpl;
Procedure TestGen_Record_RTTI_UnitImpl;
// ToDo: delay RTTI with anonymous array a:array of T, array[1..2] of T
procedure TestGen_Record_Delay_UsedByImplUses;
// ToDo: type alias type as parameter, TBird = type word;
// generic class
@ -288,7 +288,9 @@ begin
'}, []);']));
CheckSource('TestGen_Record_ClassVarRecord_UnitImpl',
LinesToStr([ // statements
'pas.UnitA.TAnt$G1.$initSpec();',
'$mod.$implcode = function () {',
' pas.UnitA.TAnt$G1.$initSpec();',
'};',
'']),
LinesToStr([ // $mod.$main
'']));
@ -355,6 +357,53 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_Record_Delay_UsedByImplUses;
begin
WithTypeInfo:=true;
StartProgram(true,[supTObject]);
AddModuleWithIntfImplSrc('UnitA.pas',
LinesToStr([
'{$modeswitch AdvancedRecords}',
'type',
' generic TBird<T> = record',
' class var a: T;',
' end;',
'']),
LinesToStr([
'']));
AddModuleWithIntfImplSrc('UnitB.pas',
LinesToStr([
'procedure Fly;',
'']),
LinesToStr([
'uses UnitA;',
'type',
' TFox = record',
' B: word;',
' end;',
'procedure Fly;',
'var Bird: specialize TBird<TFox>;',
'begin',
' if typeinfo(Bird)<>nil then ;',
' Bird.a:=Bird.a;',
'end;',
'']));
Add([
'uses UnitB;',
'begin',
' Fly;']);
ConvertProgram;
CheckSource('TestGen_Record_Delay_UsedByImplUses',
LinesToStr([ // statements
'$mod.$implcode = function () {',
' pas.UnitA.TBird$G1.$initSpec();',
'};',
'']),
LinesToStr([ // $mod.$main
'pas.UnitB.Fly();'
]));
end;
procedure TTestGenerics.TestGen_ClassEmpty;
begin
StartProgram(false);
@ -1201,7 +1250,9 @@ begin
'']));
CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
LinesToStr([ // statements
'pas.UnitA.TAnt$G1.$initSpec();',
'$mod.$implcode = function () {',
' pas.UnitA.TAnt$G1.$initSpec();',
'};',
'']),
LinesToStr([ // $mod.$main
'']));
@ -1453,7 +1504,6 @@ begin
'}, []);']));
CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
LinesToStr([ // statements
//'pas.UnitA.TAnt$G1.$initSpec();',
'']),
LinesToStr([ // $mod.$main
'']));
@ -1706,7 +1756,9 @@ begin
' rtl.addIntf(this, pas.system.IUnknown);',
'});',
'this.i = null;',
'pas.UnitA.TAnt$G1.$initSpec();',
'$mod.$implcode = function () {',
' pas.UnitA.TAnt$G1.$initSpec();',
'};',
'']),
LinesToStr([ // $mod.$main
'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.TBird.$create("Create"), pas.UnitA.TAnt$G1), true);',
@ -2424,7 +2476,9 @@ begin
'});']));
CheckSource('TestGen_Array_OtherUnit',
LinesToStr([ // statements
'pas.UnitA.$rtti["TDyn<UnitB.TAnt>"].eltype = pas.UnitB.$rtti["TAnt"];',
'$mod.$implcode = function () {',
' pas.UnitA.$rtti["TDyn<UnitB.TAnt>"].eltype = pas.UnitB.$rtti["TAnt"];',
'};',
'']),
LinesToStr([ // $mod.$main
' pas.UnitB.Run();',
@ -2504,9 +2558,11 @@ begin
'}, []);']));
CheckSource('TestGen_ArrayOfUnitImplRec',
LinesToStr([ // statements
'pas.UnitA.$rtti["TDyn<UnitA.TAnt>"].eltype = pas.UnitA.$rtti["TAnt"];',
'pas.UnitA.$rtti["TDyn<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];',
'pas.UnitA.$rtti["TStatic<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];',
'$mod.$implcode = function () {',
' pas.UnitA.$rtti["TDyn<UnitA.TAnt>"].eltype = pas.UnitA.$rtti["TAnt"];',
' pas.UnitA.$rtti["TDyn<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];',
' pas.UnitA.$rtti["TStatic<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];',
'};',
'']),
LinesToStr([ // $mod.$main
'']));
@ -2673,7 +2729,9 @@ begin
'}, []);']));
CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
LinesToStr([ // statements
'pas.UnitA.$rtti["TAnt<UnitA.TBird>"].init();',
'$mod.$implcode = function () {',
' pas.UnitA.$rtti["TAnt<UnitA.TBird>"].init();',
'};',
'']),
LinesToStr([ // $mod.$main
'']));

2
packages/pastojs/tests/testpas2js.pp
View File

@ -21,7 +21,7 @@ uses
MemCheck,
{$ENDIF}
Classes, consoletestrunner, tcconverter, TCModules, TCSrcMap,
TCFiler, TCUnitSearch, TCOptimizations, TCGenerics, TCPrecompile;
TCFiler, TCUnitSearch, TCOptimizations, TCGenerics, TCPrecompile, unit2;
type