summaryrefslogtreecommitdiff
path: root/packages/pastojs
diff options
context:
space:
mode:
authormattias <mattias@3ad0048d-3df7-0310-abae-a5850022a9f2>2019-02-17 20:43:58 +0000
committermattias <mattias@3ad0048d-3df7-0310-abae-a5850022a9f2>2019-02-17 20:43:58 +0000
commit53c934286f608c9176b440ec1d91b788915d00fb (patch)
tree495d93ef44efa63877864fba6bdbcf49f29de7e1 /packages/pastojs
parentb0a0a54bc3a7e1aedca4daf6e686f33060b3182e (diff)
downloadfpc-53c934286f608c9176b440ec1d91b788915d00fb.tar.gz
pastojs: implemented class constructors
git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@41360 3ad0048d-3df7-0310-abae-a5850022a9f2
Diffstat (limited to 'packages/pastojs')
-rw-r--r--packages/pastojs/src/fppas2js.pp389
-rw-r--r--packages/pastojs/src/pas2jsfiler.pp6
-rw-r--r--packages/pastojs/tests/tcmodules.pas102
-rw-r--r--packages/pastojs/tests/tcprecompile.pas44
4 files changed, 411 insertions, 130 deletions
diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp
index 92f09c9f96..00eba7771b 100644
--- a/packages/pastojs/src/fppas2js.pp
+++ b/packages/pastojs/src/fppas2js.pp
@@ -1613,10 +1613,12 @@ type
{$ENDIF}
private
FGlobals: TPasToJSConverterGlobals;
+ FGlobalClassMethods: TArrayOfPasProcedure;
FOnIsElementUsed: TPas2JSIsElementUsedEvent;
FOnIsTypeInfoUsed: TPas2JSIsElementUsedEvent;
FOptions: TPasToJsConverterOptions;
FReservedWords: TJSReservedWordList; // sorted with CompareStr
+ Procedure AddGlobalClassMethod(P: TPasProcedure);
Function CreatePrimitiveDotExpr(Path: string; PosEl: TPasElement): TJSElement;
Function CreateSubDeclJSNameExpr(El: TPasElement; JSName: string;
AContext: TConvertContext; PosEl: TPasElement): TJSElement;
@@ -1712,6 +1714,7 @@ type
Procedure AddToStatementList(var First, Last: TJSStatementList;
Add: TJSElement; Src: TPasElement); overload;
Procedure AddToStatementList(St: TJSStatementList; Add: TJSElement; Src: TPasElement); overload;
+ Procedure PrependToStatementList(var St: TJSElement; Add: TJSElement; PosEl: TPasElement);
Procedure AddToVarStatement(VarStat: TJSVariableStatement; Add: TJSElement;
Src: TPasElement);
Function CreateValInit(PasType: TPasType; Expr: TPasExpr; El: TPasElement;
@@ -1783,6 +1786,7 @@ type
Kind: TMemberFunc);
Procedure AddClassRTTI(El: TPasClassType; Src: TJSSourceElements;
FuncContext: TFunctionContext);
+ Procedure AddClassConstructors(FuncContext: TFunctionContext; PosEl: TPasElement);
// misc
Function CreateCallback(Expr: TPasExpr; ResolvedEl: TPasResolverResult;
AContext: TConvertContext): TJSElement; virtual;
@@ -1799,6 +1803,7 @@ type
aContext: TConvertContext; PosEl: TPasElement): TJSCallExpression; virtual;
Function CreatePrecompiledJS(El: TJSElement): string; virtual;
Function CreateRaisePropReadOnly(PosEl: TPasElement): TJSElement; virtual;
+ Procedure AddRTLVersionCheck(FuncContext: TFunctionContext; PosEl: TPasElement);
// create elements for RTTI
Function CreateTypeInfoRef(El: TPasType; AContext: TConvertContext;
ErrorEl: TPasElement): TJSElement; virtual;
@@ -1830,7 +1835,6 @@ type
Procedure AddInFrontOfFunctionTry(NewEl: TJSElement; PosEl: TPasElement;
FuncContext: TFunctionContext);
Procedure AddInterfaceReleases(FuncContext: TFunctionContext; PosEl: TPasElement);
- Procedure AddRTLVersionCheck(FuncContext: TFunctionContext; PosEl: TPasElement);
Procedure AddClassSupportedInterfaces(El: TPasClassType; Src: TJSSourceElements;
FuncContext: TFunctionContext);
// create elements for helpers
@@ -5980,6 +5984,16 @@ begin
Result:=FGlobals.BuiltInNames[bin];
end;
+procedure TPasToJSConverter.AddGlobalClassMethod(P: TPasProcedure);
+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}
+end;
+
procedure TPasToJSConverter.AddToSourceElements(Src: TJSSourceElements;
El: TJSElement);
@@ -9697,6 +9711,8 @@ var
DotExpr: TJSDotMemberExpression;
BracketJS: TJSBracketMemberExpression;
aName: TJSString;
+ Call: TJSCallExpression;
+ AssignContext: TAssignContext;
begin
Result:=nil;
@@ -9740,6 +9756,25 @@ begin
FreeAndNil(LeftJS);
Result:=CreateCallRTLFree(Obj,Prop);
end
+ else if LeftJS is TJSCallExpression then
+ begin
+ // getter().free
+ // -> setter(rtl.freeLoc(getter()))
+ AssignContext:=TAssignContext.Create(Bin.Left,nil,AContext);
+ try
+ Call:=CreateCallExpression(Bin.Left);
+ Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnFreeLocalVar)]);
+ Call.Args.AddElement(LeftJS);
+ LeftJS:=nil;
+ AssignContext.RightSide:=Call;
+ AContext.Resolver.ComputeElement(Bin.Left,AssignContext.LeftResolved,[rcNoImplicitProc]);
+ AssignContext.RightResolved:=AssignContext.LeftResolved;
+ Result:=CreateAssignStatement(Bin.Left,AssignContext);
+ finally
+ AssignContext.RightSide.Free;
+ AssignContext.Free;
+ end;
+ end
else
begin
{$IFDEF VerbosePas2JS}
@@ -12642,6 +12677,9 @@ var
Member:=TPasElement(El.Members[i]);
if not (Member is TPasProcedure) then continue;
if not IsMemberNeeded(Member) then continue;
+ if (Member.ClassType=TPasClassConstructor)
+ or (Member.ClassType=TPasClassDestructor) then
+ continue;
Arr.AddElement(CreateLiteralString(Member,TransformVariableName(Member,AContext)));
end;
end;
@@ -12844,27 +12882,30 @@ begin
P:=TPasElement(El.Members[i]);
//writeln('TPasToJSConverter.ConvertClassType methods El[',i,']=',GetObjName(P));
if not IsMemberNeeded(P) then continue;
+ NewEl:=nil;
C:=P.ClassType;
- if P is TPasProcedure then
+ if not (P is TPasProcedure) then continue;
+ if IsTObject and (C=TPasDestructor) then
begin
- if IsTObject and (C=TPasDestructor) then
+ DestructorName:=TransformVariableName(P,AContext);
+ if DestructorName<>'Destroy' then
begin
- DestructorName:=TransformVariableName(P,AContext);
- if DestructorName<>'Destroy' then
- begin
- // add 'rtl.tObjectDestroy="destroy";'
- AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,P));
- AssignSt.LHS:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbivnTObjectDestroy)]);
- AssignSt.Expr:=CreateLiteralString(P,DestructorName);
- AddToSourceElements(Src,AssignSt);
- end;
- end
- else if C=TPasConstructor then
- HasConstructor:=true;
- NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext);
+ // add 'rtl.tObjectDestroy="destroy";'
+ AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,P));
+ AssignSt.LHS:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbivnTObjectDestroy)]);
+ AssignSt.Expr:=CreateLiteralString(P,DestructorName);
+ AddToSourceElements(Src,AssignSt);
+ end;
end
- else
+ else if C=TPasConstructor then
+ HasConstructor:=true
+ else if (C=TPasClassConstructor)
+ or (C=TPasClassDestructor) then
+ begin
+ AddGlobalClassMethod(TPasProcedure(P));
continue;
+ end;
+ NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext);
if NewEl=nil then
continue; // e.g. abstract or external proc
AddToSourceElements(Src,NewEl);
@@ -13785,6 +13826,7 @@ Var
ConstSrcElems: TJSSourceElements;
ArgTypeEl, HelperForType: TPasType;
aResolver: TPas2JSResolver;
+ IsClassConDestructor: Boolean;
begin
Result:=nil;
@@ -13794,6 +13836,8 @@ begin
ProcScope:=TPas2JSProcedureScope(El.CustomData);
if ProcScope.DeclarationProc<>nil then
exit;
+ IsClassConDestructor:=(El.ClassType=TPasClassConstructor)
+ or (El.ClassType=TPasClassDestructor);
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.ConvertProcedure "',El.Name,'" Overload="',ProcScope.OverloadName,'" ',El.Parent.ClassName);
@@ -13851,7 +13895,7 @@ begin
begin
// local/nested or anonymous function
Result:=FS;
- if El.Name<>'' then
+ if (El.Name<>'') and not IsClassConDestructor then
FD.Name:=TJSString(TransformVariableName(El,AContext));
end;
@@ -14016,20 +14060,25 @@ begin
end
else
begin
- First:=nil;
- Result:=First;
- Last:=First;
- //writeln('TPasToJSConverter.ConvertImplBlockElements START El.Elements.Count=',El.Elements.Count);
- For I:=0 to El.Elements.Count-1 do
- begin
- PasImpl:=TPasImplElement(El.Elements[i]);
- JSImpl:=ConvertElement(PasImpl,AContext);
- if JSImpl=nil then
- continue; // e.g. "inherited;" when there is no ancestor proc
- //writeln('TPasToJSConverter.ConvertImplBlockElements ',i,' ',JSImpl.ClassName);
- AddToStatementList(First,Last,JSImpl,PasImpl);
+ Result:=nil;
+ try
+ First:=nil;
+ Last:=nil;
+ //writeln('TPasToJSConverter.ConvertImplBlockElements START El.Elements.Count=',El.Elements.Count);
+ For I:=0 to El.Elements.Count-1 do
+ begin
+ PasImpl:=TPasImplElement(El.Elements[i]);
+ JSImpl:=ConvertElement(PasImpl,AContext);
+ if JSImpl=nil then
+ continue; // e.g. "inherited;" when there is no ancestor proc
+ //writeln('TPasToJSConverter.ConvertImplBlockElements ',i,' ',JSImpl.ClassName);
+ AddToStatementList(First,Last,JSImpl,PasImpl);
+ end;
Result:=First;
- end;
+ finally
+ if Result=nil then
+ First.Free;
+ end;
end;
end;
@@ -14037,10 +14086,28 @@ function TPasToJSConverter.ConvertInitializationSection(
El: TInitializationSection; AContext: TConvertContext): TJSElement;
var
FDS: TJSFunctionDeclarationStatement;
- FunName: String;
+ FuncContext: TFunctionContext;
+
+ function CreateBody: TJSFunctionBody;
+ var
+ FuncDef: TJSFuncDef;
+ begin
+ FuncDef:=FDS.AFunction;
+ Result:=FuncDef.Body;
+ if Result=nil then
+ begin
+ Result:=TJSFunctionBody(CreateElement(TJSFunctionBody,El));
+ FuncDef.Body:=Result;
+ Result.A:=TJSSourceElements(CreateElement(TJSSourceElements, El));
+ end;
+ if FuncContext=nil then
+ FuncContext:=TFunctionContext.Create(El,Result,AContext);
+ end;
+
+var
+ FunName, S: String;
IsMain, NeedRTLCheckVersion: Boolean;
AssignSt: TJSSimpleAssignStatement;
- FuncContext: TFunctionContext;
Body: TJSFunctionBody;
Scope: TPas2JSInitialFinalizationScope;
Line, Col: integer;
@@ -14050,16 +14117,6 @@ begin
Result:=nil;
Scope:=TPas2JSInitialFinalizationScope(El.CustomData);
- if Scope.JS<>'' then
- begin
- // precompiled JS
- TPasResolver.UnmangleSourceLineNumber(El.Parent.SourceLinenumber,Line,Col);
- Lit:=TJSLiteral.Create(Line,Col,El.Parent.SourceFilename);
- Lit.Value.CustomValue:=StrToJSString(Scope.JS);
- Result:=Lit;
- exit;
- end;
-
IsMain:=(El.Parent<>nil) and (El.Parent is TPasProgram);
if IsMain then
FunName:=GetBIName(pbifnProgramMain)
@@ -14073,40 +14130,68 @@ begin
// $mod.$init =
AssignSt.LHS:=CreateMemberExpression([GetBIName(pbivnModule),FunName]);
// = function(){...}
- FDS:=CreateFunctionSt(El,(El.Elements.Count>0) or NeedRTLCheckVersion);
+ FDS:=CreateFunctionSt(El,false);
AssignSt.Expr:=FDS;
+ Body:=FDS.AFunction.Body;
- if El.Elements.Count>0 then
+ // first convert main/initialization statements
+ if Scope.JS<>'' then
begin
- Body:=FDS.AFunction.Body;
- FuncContext:=TFunctionContext.Create(El,Body,AContext);
+ S:=TrimRight(Scope.JS);
+ if S<>'' 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;
+
AddInterfaceReleases(FuncContext,El);
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
+
+ if length(FGlobalClassMethods)>0 then
+ begin
+ // prepend class constructors (which one depends on WPO)
+ Body:=CreateBody;
+ AddClassConstructors(FuncContext,El);
+ Body.A:=FuncContext.BodySt;
end;
if NeedRTLCheckVersion then
begin
// prepend rtl.versionCheck
- Body:=FDS.AFunction.Body;
- if FuncContext=nil then
- FuncContext:=TFunctionContext.Create(El,Body,AContext);
+ Body:=CreateBody;
AddRTLVersionCheck(FuncContext,El);
Body.A:=FuncContext.BodySt;
end;
+
Result:=AssignSt;
finally
FuncContext.Free;
if Result=nil then
AssignSt.Free;
end;
-
- if (coStoreImplJS in Options) and (AContext.Resolver<>nil) then
- Scope.JS:=CreatePrecompiledJS(Result);
end;
function TPasToJSConverter.ConvertFinalizationSection(El: TFinalizationSection;
@@ -15610,6 +15695,37 @@ begin
end;
end;
+procedure TPasToJSConverter.AddClassConstructors(FuncContext: TFunctionContext;
+ PosEl: TPasElement);
+var
+ i: Integer;
+ Proc: TPasProcedure;
+ First, Last: TJSStatementList;
+ St: TJSElement;
+ Call: TJSCallExpression;
+ Bracket: TJSUnaryBracketsExpression;
+begin
+ First:=nil;
+ Last:=nil;
+ try
+ for i:=0 to length(FGlobalClassMethods)-1 do
+ begin
+ Proc:=FGlobalClassMethods[i];
+ St:=ConvertProcedure(Proc,FuncContext);
+ // create direct call ( function(){} )();
+ Bracket:=TJSUnaryBracketsExpression(CreateElement(TJSUnaryBracketsExpression,PosEl));
+ Bracket.A:=St;
+ Call:=CreateCallExpression(PosEl);
+ Call.Expr:=Bracket;
+ AddToStatementList(First,Last,Call,PosEl);
+ end;
+ PrependToStatementList(FuncContext.BodySt,First,PosEl);
+ First:=nil;
+ finally
+ First.Free;
+ end;
+end;
+
function TPasToJSConverter.CreateCallback(Expr: TPasExpr;
ResolvedEl: TPasResolverResult; AContext: TConvertContext): TJSElement;
// El is a reference to a proc
@@ -15657,7 +15773,7 @@ begin
exit;
end;
IsHelper:=aResolver.IsHelper(Proc.Parent);
- NeedClass:=aResolver.IsClassMethod(Proc) and not Proc.IsStatic;
+ NeedClass:=aResolver.IsClassMethod(Proc) and not aResolver.MethodIsStatic(Proc);
// an of-object method -> create "rtl.createCallback(Target,func)"
TargetJS:=nil;
@@ -16156,6 +16272,7 @@ begin
aJSWriter:=TJSWriter.Create(aWriter);
aJSWriter.Options:=DefaultJSWriterOptions;
aJSWriter.IndentSize:=2;
+ aJSWriter.SkipCurlyBrackets:=true;
aJSWriter.WriteJS(El);
Result:=aWriter.AsString;
finally
@@ -16175,6 +16292,18 @@ begin
Call.AddArg(CreateLiteralJSString(PosEl,'EPropReadOnly'));
end;
+procedure TPasToJSConverter.AddRTLVersionCheck(FuncContext: TFunctionContext;
+ PosEl: TPasElement);
+var
+ Call: TJSCallExpression;
+begin
+ // rtl.checkVersion(RTLVersion)
+ Call:=CreateCallExpression(PosEl);
+ Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnCheckVersion)]);
+ Call.AddArg(CreateLiteralNumber(PosEl,FGlobals.RTLVersion));
+ PrependToStatementList(FuncContext.BodySt,Call,PosEl);
+end;
+
function TPasToJSConverter.CreateTypeInfoRef(El: TPasType;
AContext: TConvertContext; ErrorEl: TPasElement): TJSElement;
var
@@ -16398,6 +16527,10 @@ begin
exit; // overridden proc was already published in ancestor
end;
end;
+ if (Proc.ClassType=TPasClassConstructor)
+ or (Proc.ClassType=TPasClassDestructor) then
+ exit; // no RTTI for class constructor
+
OptionsEl:=nil;
ResultTypeInfo:=nil;
try
@@ -17096,41 +17229,6 @@ begin
end;
end;
-procedure TPasToJSConverter.AddRTLVersionCheck(FuncContext: TFunctionContext;
- PosEl: TPasElement);
-var
- St: TJSElement;
- Call: TJSCallExpression;
- NewSt: TJSStatementList;
-begin
- St:=FuncContext.BodySt;
- // rtl.checkVersion(RTLVersion)
- Call:=CreateCallExpression(PosEl);
- Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnCheckVersion)]);
- Call.AddArg(CreateLiteralNumber(PosEl,FGlobals.RTLVersion));
- if St=nil then
- FuncContext.BodySt:=Call
- else if St is TJSEmptyBlockStatement then
- begin
- St.Free;
- FuncContext.BodySt:=Call;
- end
- else if St is TJSStatementList then
- begin
- NewSt:=TJSStatementList(CreateElement(TJSStatementList,PosEl));
- NewSt.A:=Call;
- NewSt.B:=St;
- FuncContext.BodySt:=NewSt;
- end
- else
- begin
- {$IFDEF VerbosePas2JS}
- writeln('TPasToJSConverter.AddRTLVersionCheck St=',GetObjName(St));
- {$ENDIF}
- RaiseNotSupported(PosEl,FuncContext,20181002154026,GetObjName(St));
- end;
-end;
-
procedure TPasToJSConverter.AddClassSupportedInterfaces(El: TPasClassType;
Src: TJSSourceElements; FuncContext: TFunctionContext);
@@ -17501,7 +17599,7 @@ begin
aResolver:=AContext.Resolver;
Helper:=Proc.Parent as TPasClassType;
HelperForType:=aResolver.ResolveAliasType(Helper.HelperForType);
- IsStatic:=ptmStatic in Proc.ProcType.Modifiers;
+ IsStatic:=aResolver.MethodIsStatic(Proc);
WithExprScope:=nil;
SelfScope:=nil;
PosEl:=Expr;
@@ -19708,6 +19806,34 @@ begin
AddToStatementList(First,Last,Add,Src);
end;
+procedure TPasToJSConverter.PrependToStatementList(var St: TJSElement;
+ Add: TJSElement; PosEl: TPasElement);
+var
+ NewSt: TJSStatementList;
+begin
+ if St=nil then
+ St:=Add
+ else if St is TJSEmptyBlockStatement then
+ begin
+ St.Free;
+ St:=Add;
+ end
+ else if St is TJSStatementList then
+ begin
+ NewSt:=TJSStatementList(CreateElement(TJSStatementList,PosEl));
+ NewSt.A:=Add;
+ NewSt.B:=St;
+ St:=NewSt;
+ end
+ else
+ begin
+ {$IFDEF VerbosePas2JS}
+ writeln('TPasToJSConverter.PrependToStatementList St=',GetObjName(St));
+ {$ENDIF}
+ RaiseNotSupported(PosEl,nil,20181002154026,GetObjName(St));
+ end;
+end;
+
procedure TPasToJSConverter.AddToVarStatement(VarStat: TJSVariableStatement;
Add: TJSElement; Src: TPasElement);
var
@@ -20341,6 +20467,8 @@ function TPasToJSConverter.CreateReferencePath(El: TPasElement;
- auto created local var
otherwise use absolute path
}
+var
+ aResolver: TPas2JSResolver;
function IsLocalVar: boolean;
begin
@@ -20349,7 +20477,7 @@ function TPasToJSConverter.CreateReferencePath(El: TPasElement;
exit(true);
if El.ClassType=TPasResultElement then
exit(true);
- if AContext.Resolver=nil then
+ if aResolver=nil then
exit(true);
if El.Parent=nil then
RaiseNotSupported(El,AContext,20170203121306,GetObjName(El));
@@ -20378,16 +20506,27 @@ function TPasToJSConverter.CreateReferencePath(El: TPasElement;
Result:=true;
end;
- function IsClassFunction(Proc: TPasElement): boolean;
+ function IsClassProc(Proc: TPasElement): boolean;
var
C: TClass;
begin
if Proc=nil then exit(false);
C:=Proc.ClassType;
Result:=(C=TPasClassFunction) or (C=TPasClassProcedure)
+ or (C=TPasClassOperator)
or (C=TPasClassConstructor) or (C=TPasClassDestructor);
end;
+ function IsNonStaticClassProc(Proc: TPasElement): boolean;
+ var
+ C: TClass;
+ begin
+ if Proc=nil then exit(false);
+ C:=Proc.ClassType;
+ Result:=((C=TPasClassFunction) or (C=TPasClassProcedure) or (C=TPasClassOperator))
+ and not TPasProcedure(Proc).IsStatic;
+ end;
+
procedure Append_GetClass(Member: TPasElement);
begin
if Member.Parent is TPasClassType then
@@ -20414,7 +20553,7 @@ function TPasToJSConverter.CreateReferencePath(El: TPasElement;
var
AbsolResolved: TPasResolverResult;
begin
- AContext.Resolver.ComputeElement(TPasVariable(El).AbsoluteExpr,AbsolResolved,[rcNoImplicitProc]);
+ aResolver.ComputeElement(TPasVariable(El).AbsoluteExpr,AbsolResolved,[rcNoImplicitProc]);
Result:=CreateReferencePath(AbsolResolved.IdentEl,AContext,Kind,Full,Ref);
end;
@@ -20463,8 +20602,9 @@ begin
//writeln('TPasToJSConverter.CreateReferencePath START El=',GetObjName(El),' Parent=',GetObjName(El.Parent),' Context=',GetObjName(AContext),' SelfContext=',GetObjName(AContext.GetSelfContext));
//AContext.WriteStack;
{$ENDIF}
+ aResolver:=AContext.Resolver;
if (El is TPasType) and (AContext<>nil) then
- El:=AContext.Resolver.ResolveAliasType(TPasType(El));
+ El:=aResolver.ResolveAliasType(TPasType(El));
ElClass:=El.ClassType;
if ElClass.InheritsFrom(TPasVariable) and (TPasVariable(El).AbsoluteExpr<>nil)
@@ -20474,26 +20614,23 @@ begin
if AContext is TDotContext then
begin
Dot:=TDotContext(AContext);
- if Dot.Resolver<>nil then
+ if aResolver<>nil then
begin
if ElClass.InheritsFrom(TPasVariable) then
begin
//writeln('TPasToJSConverter.CreateReferencePath Left=',GetResolverResultDbg(Dot.LeftResolved),' Right=class var ',GetObjName(El));
if ([vmClass,vmStatic]*ClassVarModifiersType*TPasVariable(El).VarModifiers<>[])
and (Dot.Access=caAssign)
- and Dot.Resolver.ResolvedElIsClassOrRecordInstance(Dot.LeftResolved) then
+ and aResolver.ResolvedElIsClassOrRecordInstance(Dot.LeftResolved) then
begin
- // writing a class var
+ // writing a class var or class const
Append_GetClass(El);
end;
end
- else if IsClassFunction(El) then
- begin
- if (not TPasProcedure(El).IsStatic)
- and Dot.Resolver.ResolvedElIsClassOrRecordInstance(Dot.LeftResolved) then
- // accessing a class method from an object, 'this' must be the class/record
- Append_GetClass(El);
- end;
+ else if IsNonStaticClassProc(El)
+ and aResolver.ResolvedElIsClassOrRecordInstance(Dot.LeftResolved) then
+ // accessing a class method from an object, 'this' must be the class/record
+ Append_GetClass(El);
end;
end
else if IsLocalVar then
@@ -20534,7 +20671,7 @@ begin
RaiseNotSupported(WithData.Expr,AContext,20190209092506,GetObjName(El));
Prepend(Result,WithData.WithVarName);
if not (wesfOnlyTypeMembers in WithData.Flags)
- and IsClassFunction(El) and (not TPasProcedure(El).IsStatic) then
+ and IsNonStaticClassProc(El) then
begin
// with Obj do NonStaticClassMethod -> append .$class
Append_GetClass(El);
@@ -20603,29 +20740,30 @@ begin
// helpers have no self
Prepend(Result,ParentEl.Name)
else if (SelfContext<>nil)
- and IsA(TPasType(SelfContext.ThisPas),TPasType(ParentEl)) then
+ and IsA(TPasType(SelfContext.ThisPas),TPasMembersType(ParentEl)) then
begin
ShortName:=SelfContext.GetLocalName(SelfContext.ThisPas);
Prepend(Result,ShortName);
end
else
begin
+ Prepend(Result,ParentEl.Name);
// missing JS var for Self
- {$IFDEF VerbosePas2JS}
- {AllowWriteln}
- writeln('TPasToJSConverter.CreateReferencePath missing JS var for Self: El=',GetElementDbgPath(El),':',El.ClassName,' CurParentEl=',GetElementDbgPath(ParentEl),':',ParentEl.ClassName,' AContext:');
- AContext.WriteStack;
- if Ref<>nil then
- writeln('TPasToJSConverter.CreateReferencePath Ref=',GetObjName(Ref.Element),' at ',AContext.Resolver.GetElementSourcePosStr(Ref.Element));
- {AllowWriteln-}
- {$ENDIF}
- RaiseNotSupported(El,AContext,20180125004049);
+ //{$IFDEF VerbosePas2JS}
+ //{AllowWriteln}
+ //writeln('TPasToJSConverter.CreateReferencePath missing JS var for Self: El=',GetElementDbgPath(El),':',El.ClassName,' CurParentEl=',GetElementDbgPath(ParentEl),':',ParentEl.ClassName,' AContext:');
+ //AContext.WriteStack;
+ //if Ref<>nil then
+ // writeln('TPasToJSConverter.CreateReferencePath Ref=',GetObjName(Ref.Element),' at ',aResolver.GetElementSourcePosStr(Ref.Element));
+ //{AllowWriteln-}
+ //{$ENDIF}
+ //RaiseNotSupported(El,AContext,20180125004049);
end;
if (El.Parent=ParentEl) and (SelfContext<>nil)
- and not IsClassFunction(SelfContext.PasElement) then
+ and not IsClassProc(SelfContext.PasElement) then
begin
// inside a method -> Self is a class instance
- if IsClassFunction(El)
+ if IsNonStaticClassProc(El)
and (TPasClassType(El.Parent).HelperForType=nil) then
Append_GetClass(El); // accessing a class function
end;
@@ -21750,10 +21888,17 @@ begin
end
else if C.InheritsFrom(TPasProcedure) then
begin
- Methods.Add(P);
- if (C=TPasConstructor)
- or ((aResolver<>nil) and aResolver.IsClassMethod(P)) then
- IsFull:=true;
+ if (C=TPasClassConstructor)
+ or (C=TPasClassDestructor) then
+ AddGlobalClassMethod(TPasProcedure(P))
+ else
+ begin
+ Methods.Add(P);
+ if (C=TPasConstructor)
+ or ((aResolver<>nil) and aResolver.IsClassMethod(P)
+ and not aResolver.MethodIsStatic(TPasProcedure(P))) then
+ IsFull:=true; // needs $record
+ end;
continue;
end
else
diff --git a/packages/pastojs/src/pas2jsfiler.pp b/packages/pastojs/src/pas2jsfiler.pp
index dd57925b07..9569e4a94d 100644
--- a/packages/pastojs/src/pas2jsfiler.pp
+++ b/packages/pastojs/src/pas2jsfiler.pp
@@ -71,13 +71,15 @@ uses
const
PCUMagic = 'Pas2JSCache';
- PCUVersion = 3;
+ PCUVersion = 4;
{ Version Changes:
1: initial version
2: - TPasProperty.ImplementsFunc:String -> Implements:TPasExprArray
- pcsfAncestorResolved
- removed msIgnoreInterfaces
- 3: changed records from function to objects
+ 3: changed records from function to objects (pas2js 1.3)
+ 4: precompiled JS of initialization section now only contains the statements,
+ not the whole $init function (pas2js 1.5)
}
BuiltInNodeName = 'BuiltIn';
diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas
index 8c2ce1722c..e44f89d027 100644
--- a/packages/pastojs/tests/tcmodules.pas
+++ b/packages/pastojs/tests/tcmodules.pas
@@ -441,7 +441,6 @@ type
Procedure TestArrayOfConst_TVarRec;
Procedure TestArrayOfConst_PassBaseTypes;
Procedure TestArrayOfConst_PassObj;
- // ToDo: tcfiler TPasModuleScope.SystemTVarRec TPas2JSModuleScope.SystemVarRecs
// record
Procedure TestRecord_Empty;
@@ -474,7 +473,8 @@ type
Procedure TestAdvRecord_SubClass;
Procedure TestAdvRecord_SubInterfaceFail;
Procedure TestAdvRecord_Constructor;
- // ToDo: class constructor
+ Procedure TestAdvRecord_ClassConstructor;
+ // ToDo: classconstructor pcu
// classes
Procedure TestClass_TObjectDefaultConstructor;
@@ -525,6 +525,7 @@ type
Procedure TestClass_NestedProcClassSelf;
Procedure TestClass_NestedProcCallInherited;
Procedure TestClass_TObjectFree;
+ Procedure TestClass_TObjectFree_VarArg;
Procedure TestClass_TObjectFreeNewInstance;
Procedure TestClass_TObjectFreeLowerCase;
Procedure TestClass_TObjectFreeFunctionFail;
@@ -11136,6 +11137,62 @@ begin
'']));
end;
+procedure TTestModule.TestAdvRecord_ClassConstructor;
+begin
+ StartProgram(false);
+ Add([
+ '{$modeswitch AdvancedRecords}',
+ 'type',
+ ' TPoint = record',
+ ' class var x: longint;',
+ ' class procedure Fly; static;',
+ ' class constructor Init;',
+ ' end;',
+ '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;',
+ 'var r: TPoint;',
+ 'begin',
+ ' r.x:=10;',
+ '']);
+ ConvertProgram;
+ CheckSource('TestAdvRecord_ClassConstructor',
+ LinesToStr([ // statements
+ 'rtl.recNewT($mod, "TPoint", function () {',
+ ' this.x = 0;',
+ ' this.$eq = function (b) {',
+ ' return true;',
+ ' };',
+ ' this.$assign = function (s) {',
+ ' return this;',
+ ' };',
+ ' this.Fly = function () {',
+ ' };',
+ '}, true);',
+ 'this.count = 0;',
+ 'this.r = $mod.TPoint.$new();',
+ '']),
+ LinesToStr([ // $mod.$main
+ '(function () {',
+ ' $mod.count = $mod.count + 1;',
+ ' $mod.TPoint.x = 3;',
+ ' $mod.TPoint.x = 4;',
+ ' $mod.TPoint.Fly();',
+ ' $mod.TPoint.Fly();',
+ '})();',
+ '$mod.TPoint.x = 10;',
+ '']));
+end;
+
procedure TTestModule.TestClass_TObjectDefaultConstructor;
begin
StartProgram(false);
@@ -13985,6 +14042,47 @@ begin
'']));
end;
+procedure TTestModule.TestClass_TObjectFree_VarArg;
+begin
+ StartProgram(false);
+ Add([
+ 'type',
+ ' TObject = class',
+ ' Obj: tobject;',
+ ' procedure Free;',
+ ' end;',
+ 'procedure tobject.free;',
+ 'begin',
+ 'end;',
+ 'procedure DoIt(var o: tobject);',
+ 'begin',
+ ' o.free;',
+ ' o.free();',
+ 'end;',
+ 'begin',
+ '']);
+ ConvertProgram;
+ CheckSource('TestClass_TObjectFree_VarArg',
+ LinesToStr([ // statements
+ 'rtl.createClass($mod, "TObject", null, function () {',
+ ' this.$init = function () {',
+ ' this.Obj = null;',
+ ' };',
+ ' this.$final = function () {',
+ ' this.Obj = undefined;',
+ ' };',
+ ' this.Free = function () {',
+ ' };',
+ '});',
+ 'this.DoIt = function (o) {',
+ ' o.set(rtl.freeLoc(o.get()));',
+ ' o.set(rtl.freeLoc(o.get()));',
+ '};',
+ '']),
+ LinesToStr([ // $mod.$main
+ '']));
+end;
+
procedure TTestModule.TestClass_TObjectFreeNewInstance;
begin
StartProgram(false);
diff --git a/packages/pastojs/tests/tcprecompile.pas b/packages/pastojs/tests/tcprecompile.pas
index fc5680d3ce..a984dd5ca3 100644
--- a/packages/pastojs/tests/tcprecompile.pas
+++ b/packages/pastojs/tests/tcprecompile.pas
@@ -59,8 +59,9 @@ type
procedure TestPCU_Overloads;
procedure TestPCU_Overloads_MDelphi_ModeObjFPC;
procedure TestPCU_UnitCycle;
- procedure TestPCU_ClassForward;
- procedure TestPCU_ClassConstructor;
+ procedure TestPCU_Class_Forward;
+ procedure TestPCU_Class_Constructor;
+ procedure TestPCU_Class_ClassConstructor;
procedure TestPCU_ClassInterface;
procedure TestPCU_Namespace;
procedure TestPCU_CheckVersionMain;
@@ -300,7 +301,7 @@ begin
CheckPrecompile('test1.pas','src');
end;
-procedure TTestCLI_Precompile.TestPCU_ClassForward;
+procedure TTestCLI_Precompile.TestPCU_Class_Forward;
begin
AddUnit('src/system.pp',[
'type integer = longint;',
@@ -339,7 +340,7 @@ begin
CheckPrecompile('test1.pas','src');
end;
-procedure TTestCLI_Precompile.TestPCU_ClassConstructor;
+procedure TTestCLI_Precompile.TestPCU_Class_Constructor;
begin
AddUnit('src/system.pp',[
'type integer = longint;',
@@ -379,6 +380,41 @@ begin
CheckPrecompile('test1.pas','src');
end;
+procedure TTestCLI_Precompile.TestPCU_Class_ClassConstructor;
+begin
+ AddUnit('src/system.pp',[
+ 'type integer = longint;',
+ 'procedure Writeln; varargs;'],
+ ['procedure Writeln; begin end;']);
+ AddUnit('src/unit1.pp',[
+ 'type',
+ ' TObject = class',
+ ' constructor Create;',
+ ' end;',
+ ' TBird = class',
+ ' class constructor Init;',
+ ' end;',
+ ''],[
+ 'constructor TObject.Create; begin end;',
+ 'class constructor TBird.Init; begin end;',
+ '']);
+ AddUnit('src/unit2.pp',[
+ 'uses unit1;',
+ 'procedure DoIt;',
+ ''],[
+ 'procedure DoIt;',
+ 'begin',
+ ' TBird.Create;',
+ 'end;',
+ '']);
+ AddFile('test1.pas',[
+ 'uses unit2;',
+ 'begin',
+ ' DoIt;',
+ 'end.']);
+ CheckPrecompile('test1.pas','src');
+end;
+
procedure TTestCLI_Precompile.TestPCU_ClassInterface;
begin
AddUnit('src/system.pp',[