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

pastojs: fixed class constructor without initialization and precompile

Browse Source 
git-svn-id: trunk@41500 -
This commit is contained in:
Mattias Gaertner 2019-02-26 22:34:01 +00:00
parent 463e98ccef
commit f63295ce4f
3 changed files with 178 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1436,6 +1436,7 @@ type
ScannerModeSwitches: TModeSwitches;
constructor Create(PasEl: TPasElement; JSEl: TJSElement; aParent: TConvertContext); virtual;
function GetRootModule: TPasModule;
function GetRootContext: TConvertContext;
function GetNonDotContext: TConvertContext;
function GetFunctionContext: TFunctionContext;
function GetLocalName(El: TPasElement): string; virtual;
@ -1456,6 +1457,9 @@ type
TRootContext = Class(TConvertContext)
public
ResourceStrings: TJSVarDeclaration;
GlobalClassMethods: TArrayOfPasProcedure;
procedure AddGlobalClassMethod(p: TPasProcedure);
destructor Destroy; override;
end;
{ TFCLocalIdentifier }
@ -1622,12 +1626,11 @@ type
{$ENDIF}
private
FGlobals: TPasToJSConverterGlobals;
FGlobalClassMethods: TArrayOfPasProcedure;
FOnIsElementUsed: TPas2JSIsElementUsedEvent;
FOnIsTypeInfoUsed: TPas2JSIsElementUsedEvent;
FOptions: TPasToJsConverterOptions;
FReservedWords: TJSReservedWordList; // sorted with CompareStr
Procedure AddGlobalClassMethod(P: TPasProcedure);
Procedure AddGlobalClassMethod(aContext: TConvertContext; P: TPasProcedure);
Function CreatePrimitiveDotExpr(Path: string; PosEl: TPasElement): TJSElement;
Function CreateSubDeclJSNameExpr(El: TPasElement; JSName: string;
AContext: TConvertContext; PosEl: TPasElement): TJSElement;
@ -1874,7 +1877,7 @@ type
Function ConvertRepeatStatement(El: TPasImplRepeatUntil; AContext: TConvertContext): TJSElement; virtual;
Function ConvertForStatement(El: TPasImplForLoop; AContext: TConvertContext): TJSElement; virtual;
Function ConvertFinalizationSection(El: TFinalizationSection; AContext: TConvertContext): TJSElement; virtual;
Function ConvertInitializationSection(El: TInitializationSection; AContext: TConvertContext): TJSElement; virtual;
Function ConvertInitializationSection(El: TPasModule; AContext: TConvertContext): TJSElement; virtual;
Function ConvertSimpleStatement(El: TPasImplSimple; AContext: TConvertContext): TJSElement; virtual;
Function ConvertWithStatement(El: TPasImplWithDo; AContext: TConvertContext): TJSElement; virtual;
Function ConvertTryStatement(El: TPasImplTry; AContext: TConvertContext ): TJSElement; virtual;
@ -2128,6 +2131,23 @@ begin
Result:='['+Result+']';
end;
{ TRootContext }
procedure TRootContext.AddGlobalClassMethod(p: TPasProcedure);
begin
{$IF defined(fpc) and (FPC_FULLVERSION<30101)}
SetLength(GlobalClassMethods,length(GlobalClassMethods)+1);
GlobalClassMethods[length(GlobalClassMethods)-1]:=P;
{$ELSE}
Insert(P,GlobalClassMethods,length(GlobalClassMethods));
{$ENDIF}
end;
destructor TRootContext.Destroy;
begin
inherited Destroy;
end;
{ TPasToJSConverterGlobals }
constructor TPasToJSConverterGlobals.Create(TheOwner: TObject);
@ -5831,6 +5851,13 @@ begin
Result:=nil;
end;
function TConvertContext.GetRootContext: TConvertContext;
begin
Result:=Self;
while Result.Parent<>nil do
Result:=Result.Parent;
end;
function TConvertContext.GetNonDotContext: TConvertContext;
begin
Result:=Self;
@ -6005,14 +6032,15 @@ begin
Result:=FGlobals.BuiltInNames[bin];
end;
procedure TPasToJSConverter.AddGlobalClassMethod(P: TPasProcedure);
procedure TPasToJSConverter.AddGlobalClassMethod(aContext: TConvertContext;
P: TPasProcedure);
var
RootContext: TConvertContext;
begin
{$IF defined(fpc) and (FPC_FULLVERSION<30101)}
SetLength(FGlobalClassMethods,length(FGlobalClassMethods)+1);
FGlobalClassMethods[length(FGlobalClassMethods)-1]:=P;
{$ELSE}
Insert(P,FGlobalClassMethods,length(FGlobalClassMethods));
{$ENDIF}
RootContext:=aContext.GetRootContext;
if not (RootContext is TRootContext) then
DoError(20190226232141,RootContext.ClassName);
TRootContext(RootContext).AddGlobalClassMethod(P);
end;
procedure TPasToJSConverter.AddToSourceElements(Src: TJSSourceElements;
@ -12945,7 +12973,8 @@ begin
else if (C=TPasClassConstructor)
or (C=TPasClassDestructor) then
begin
AddGlobalClassMethod(TPasProcedure(P));
writeln('FFF2 TPasToJSConverter.ConvertClassType ',GetObjName(P));
AddGlobalClassMethod(AContext,TPasProcedure(P));
continue;
end;
NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext);
@ -14079,11 +14108,12 @@ begin
end;
end;
function TPasToJSConverter.ConvertInitializationSection(
El: TInitializationSection; AContext: TConvertContext): TJSElement;
function TPasToJSConverter.ConvertInitializationSection(El: TPasModule;
AContext: TConvertContext): TJSElement;
var
FDS: TJSFunctionDeclarationStatement;
FuncContext: TFunctionContext;
PosEl: TPasElement;
function CreateBody: TJSFunctionBody;
var
@ -14093,12 +14123,12 @@ var
Result:=FuncDef.Body;
if Result=nil then
begin
Result:=TJSFunctionBody(CreateElement(TJSFunctionBody,El));
Result:=TJSFunctionBody(CreateElement(TJSFunctionBody,PosEl));
FuncDef.Body:=Result;
Result.A:=TJSSourceElements(CreateElement(TJSSourceElements, El));
Result.A:=TJSSourceElements(CreateElement(TJSSourceElements, PosEl));
end;
if FuncContext=nil then
FuncContext:=TFunctionContext.Create(El,Result,AContext);
FuncContext:=TFunctionContext.Create(PosEl,Result,AContext);
end;
var
@ -14109,65 +14139,80 @@ var
Scope: TPas2JSInitialFinalizationScope;
Line, Col: integer;
Lit: TJSLiteral;
Section: TInitializationSection;
RootContext: TRootContext;
begin
// create: '$mod.$init=function(){}'
Result:=nil;
Scope:=TPas2JSInitialFinalizationScope(El.CustomData);
IsMain:=(El.Parent<>nil) and (El.Parent is TPasProgram);
Section:=El.InitializationSection;
if Section<>nil then
begin
PosEl:=Section;
Scope:=TPas2JSInitialFinalizationScope(Section.CustomData);
end
else
begin
PosEl:=El;
Scope:=nil;
end;
IsMain:=(El is TPasProgram);
if IsMain then
FunName:=GetBIName(pbifnProgramMain)
else
FunName:=GetBIName(pbifnUnitInit);
NeedRTLCheckVersion:=IsMain and (coRTLVersionCheckMain in Options);
RootContext:=AContext.GetRootContext as TRootContext;
FuncContext:=nil;
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,PosEl));
try
// $mod.$init =
AssignSt.LHS:=CreateMemberExpression([GetBIName(pbivnModule),FunName]);
// = function(){...}
FDS:=CreateFunctionSt(El,false);
FDS:=CreateFunctionSt(PosEl,false);
AssignSt.Expr:=FDS;
Body:=FDS.AFunction.Body;
// first convert main/initialization statements
if Scope.JS<>'' then
begin
S:=TrimRight(Scope.JS);
if S<>'' then
if Section<>nil then
if Scope.JS<>'' then
begin
S:=TrimRight(Scope.JS);
if S<>'' then
begin
Body:=CreateBody;
// use precompiled JS
TPasResolver.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col);
Lit:=TJSLiteral.Create(Line,Col,El.SourceFilename);
Lit.Value.CustomValue:=StrToJSString(S);
Body.A:=Lit;
end;
end
else if Section.Elements.Count>0 then
begin
Body:=CreateBody;
// use precompiled JS
TPasResolver.UnmangleSourceLineNumber(El.Parent.SourceLinenumber,Line,Col);
Lit:=TJSLiteral.Create(Line,Col,El.Parent.SourceFilename);
Lit.Value.CustomValue:=StrToJSString(S);
Body.A:=Lit;
end;
end
else if El.Elements.Count>0 then
begin
Body:=CreateBody;
// Note: although the rtl sets 'this' as the module, the function can
// simply refer to $mod, so no need to set ThisPas here
Body.A:=ConvertImplBlockElements(El,FuncContext,false);
FuncContext.BodySt:=Body.A;
// Note: although the rtl sets 'this' as the module, the function can
// simply refer to $mod, so no need to set ThisPas here
Body.A:=ConvertImplBlockElements(Section,FuncContext,false);
FuncContext.BodySt:=Body.A;
AddInterfaceReleases(FuncContext,El);
Body.A:=FuncContext.BodySt;
AddInterfaceReleases(FuncContext,PosEl);
Body.A:=FuncContext.BodySt;
// store precompiled JS
if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
begin
Scope.JS:=TrimRight(CreatePrecompiledJS(Body.A));
if Scope.JS='' then
Scope.JS:=' '; // store the information, that there is an empty initialization section
end;
end
else if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
Scope.JS:=' '; // store the information, that there is an empty initialization section
// store precompiled JS
if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
begin
Scope.JS:=TrimRight(CreatePrecompiledJS(Body.A));
if Scope.JS='' then
Scope.JS:=' '; // store the information, that there is an empty initialization section
end;
end
else if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
Scope.JS:=' '; // store the information, that there is an empty initialization section
if length(FGlobalClassMethods)>0 then
if length(RootContext.GlobalClassMethods)>0 then
begin
// prepend class constructors (which one depends on WPO)
Body:=CreateBody;
@ -14588,10 +14633,14 @@ end;
procedure TPasToJSConverter.CreateInitSection(El: TPasModule;
Src: TJSSourceElements; AContext: TConvertContext);
var
RootContext: TRootContext;
begin
RootContext:=AContext.GetRootContext as TRootContext;
// add initialization section
if Assigned(El.InitializationSection) then
AddToSourceElements(Src,ConvertInitializationSection(El.InitializationSection,AContext));
if Assigned(El.InitializationSection)
or (length(RootContext.GlobalClassMethods)>0) then
AddToSourceElements(Src,ConvertInitializationSection(El,AContext));
// finalization: not supported
if Assigned(El.FinalizationSection) then
raise Exception.Create('TPasToJSConverter.ConvertInitializationSection: finalization section is not supported');
@ -15636,13 +15685,16 @@ var
St: TJSElement;
Call: TJSCallExpression;
Bracket: TJSUnaryBracketsExpression;
RootContext: TRootContext;
begin
RootContext:=TRootContext(FuncContext.GetRootContext);
First:=nil;
Last:=nil;
try
for i:=0 to length(FGlobalClassMethods)-1 do
writeln('FFF1 TPasToJSConverter.AddClassConstructors ',length(RootContext.GlobalClassMethods));
for i:=0 to length(RootContext.GlobalClassMethods)-1 do
begin
Proc:=FGlobalClassMethods[i];
Proc:=RootContext.GlobalClassMethods[i];
St:=ConvertProcedure(Proc,FuncContext);
// create direct call ( function(){} )();
Bracket:=TJSUnaryBracketsExpression(CreateElement(TJSUnaryBracketsExpression,PosEl));
@ -18232,7 +18284,7 @@ begin
else if (El.ClassType=TPasImplBeginBlock) then
Result:=ConvertBeginEndStatement(TPasImplBeginBlock(El),AContext,true)
else if (El.ClassType=TInitializationSection) then
Result:=ConvertInitializationSection(TInitializationSection(El),AContext)
Result:=ConvertInitializationSection(TPasModule(El.Parent),AContext)
else if (El.ClassType=TFinalizationSection) then
Result:=ConvertFinalizationSection(TFinalizationSection(El),AContext)
else if (El.ClassType=TPasImplTry) then
@ -22231,7 +22283,7 @@ begin
begin
if (C=TPasClassConstructor)
or (C=TPasClassDestructor) then
AddGlobalClassMethod(TPasProcedure(P))
AddGlobalClassMethod(AContext,TPasProcedure(P))
else
begin
Methods.Add(P);

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

@ -473,7 +473,8 @@ type
Procedure TestAdvRecord_SubClass;
Procedure TestAdvRecord_SubInterfaceFail;
Procedure TestAdvRecord_Constructor;
Procedure TestAdvRecord_ClassConstructor;
Procedure TestAdvRecord_ClassConstructor_Program;
Procedure TestAdvRecord_ClassConstructor_Unit;
// classes
Procedure TestClass_TObjectDefaultConstructor;
@ -11140,7 +11141,7 @@ begin
'']));
end;
procedure TTestModule.TestAdvRecord_ClassConstructor;
procedure TTestModule.TestAdvRecord_ClassConstructor_Program;
begin
StartProgram(false);
Add([
@ -11168,7 +11169,7 @@ begin
' r.x:=10;',
'']);
ConvertProgram;
CheckSource('TestAdvRecord_ClassConstructor',
CheckSource('TestAdvRecord_ClassConstructor_Program',
LinesToStr([ // statements
'rtl.recNewT($mod, "TPoint", function () {',
' this.x = 0;',
@ -11196,6 +11197,62 @@ begin
'']));
end;
procedure TTestModule.TestAdvRecord_ClassConstructor_Unit;
begin
StartUnit(false);
Add([
'interface',
'{$modeswitch AdvancedRecords}',
'type',
' TPoint = record',
' class var x: longint;',
' class procedure Fly; static;',
' class constructor Init;',
' end;',
'implementation',
'var count: word;',
'class procedure Tpoint.Fly;',
'begin',
'end;',
'class constructor tpoint.init;',
'begin',
' count:=count+1;',
' x:=3;',
' tpoint.x:=4;',
' fly;',
' tpoint.fly;',
'end;',
'']);
ConvertUnit;
CheckSource('TestAdvRecord_ClassConstructor_Unit',
LinesToStr([ // statements
'var $impl = $mod.$impl;',
'rtl.recNewT($mod, "TPoint", function () {',
' this.x = 0;',
' this.$eq = function (b) {',
' return true;',
' };',
' this.$assign = function (s) {',
' return this;',
' };',
' this.Fly = function () {',
' };',
'}, true);',
'']),
LinesToStr([ // $mod.$init
'(function () {',
' $impl.count = $impl.count + 1;',
' $mod.TPoint.x = 3;',
' $mod.TPoint.x = 4;',
' $mod.TPoint.Fly();',
' $mod.TPoint.Fly();',
'})();',
'']),
LinesToStr([ // $mod.$main
'$impl.count = 0;',
'']));
end;
procedure TTestModule.TestClass_TObjectDefaultConstructor;
begin
StartProgram(false);

11
packages/pastojs/tests/tcprecompile.pas
View File

@ -137,6 +137,10 @@ begin
if not CheckSrcDiff(OrigSrc,NewSrc,s) then
begin
WriteSources;
writeln('TCustomTestCLI_Precompile.CheckPrecompile OrigSrc==================');
writeln(OrigSrc);
writeln('TCustomTestCLI_Precompile.CheckPrecompile NewSrc==================');
writeln(NewSrc);
Fail('test1.js: '+s);
end;
end;
@ -392,11 +396,14 @@ begin
' constructor Create;',
' end;',
' TBird = class',
' class constructor Init;',
' class constructor InitBird;',
' end;',
''],[
'constructor TObject.Create; begin end;',
'class constructor TBird.Init; begin end;',
'class constructor TBird.InitBird;',
'begin',
' exit;',
'end;',
'']);
AddUnit('src/unit2.pp',[
'uses unit1;',