From c617546fcd6bb7269b6a00f94d2db362b7a977b9 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Fri, 8 Feb 2019 17:52:42 +0000 Subject: [PATCH] pastojs: record helper constructor git-svn-id: trunk@41259 - --- packages/fcl-passrc/src/pasresolver.pp | 2 + packages/pastojs/src/fppas2js.pp | 704 +++++++++++++++---------- packages/pastojs/tests/tcmodules.pas | 447 +++++++++++++++- 3 files changed, 855 insertions(+), 298 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index f19af82926..bc4f186479 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -15882,6 +15882,8 @@ begin else if ((C=TPasVariable) or (C=TPasProperty)) and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then // ok + else if IsHelper(FindData.Found.Parent) then + // ok else begin RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX, diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 194171e736..7ed70bbcef 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -1621,6 +1621,7 @@ type procedure SetUseSwitchStatement(const AValue: boolean); protected type + TMemberFunc = (mfInit, mfFinalize); TConvertJSEvent = function(El: TPasElement; AContext: TConvertContext; Data: Pointer): TJSElement of object; TCreateRefPathData = record El: TPasElement; @@ -1757,6 +1758,12 @@ type OpCode: TExprOpCode): TJSElement; virtual; Function CreateCloneStaticArray(El: TPasElement; ArrTypeEl: TPasArrayType; ArrayExpr: TJSElement; AContext: TConvertContext): TJSElement; virtual; + // class + Procedure AddInstanceMemberFunction(El: TPasClassType; Src: TJSSourceElements; + ClassContext: TConvertContext; IsTObject: boolean; Ancestor: TPasType; + Kind: TMemberFunc); + Procedure AddClassRTTI(El: TPasClassType; Src: TJSSourceElements; + FuncContext: TFunctionContext); // misc Function CreateCallback(Expr: TPasExpr; ResolvedEl: TPasResolverResult; AContext: TConvertContext): TJSElement; virtual; @@ -1804,9 +1811,13 @@ type 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 Function CreateCallHelperMethod(Proc: TPasProcedure; Expr: TPasExpr; AContext: TConvertContext; Implicit: boolean = false): TJSCallExpression; virtual; + Procedure AddHelperConstructor(El: TPasClassType; Src: TJSSourceElements; + AContext: TConvertContext); virtual; // Statements Function ConvertImplBlockElements(El: TPasImplBlock; AContext: TConvertContext; NilIfEmpty: boolean): TJSElement; virtual; Function ConvertBeginEndStatement(El: TPasImplBeginBlock; AContext: TConvertContext; NilIfEmpty: boolean): TJSElement; virtual; @@ -3799,7 +3810,7 @@ begin if TPasClassType(HelperForType).IsExternal then begin // method of a class helper for external class - if not (ptmStatic in El.Modifiers) then + if IsClassMethod(El) and not (ptmStatic in El.Modifiers) then RaiseMsg(20190201165259,nHelperClassMethodForExtClassMustBeStatic, sHelperClassMethodForExtClassMustBeStatic,[],El); if El.ClassType=TPasConstructor then @@ -12451,13 +12462,6 @@ function TPasToJSConverter.ConvertClassType(El: TPasClassType; this.i = 0; }); *) -type - TMemberFunc = (mfInit, mfFinalize); -const - MemberFuncName: array[TMemberFunc] of string = ( - '$init', - '$final' - ); var IsTObject, AncestorIsExternal: boolean; @@ -12466,7 +12470,7 @@ var if IsElementUsed(aMember) then exit(true); if IsTObject then begin - if aMember is TPasProcedure then + if aMember.ClassType=TPasProcedure then begin if (CompareText(aMember.Name,'AfterConstruction')=0) or (CompareText(aMember.Name,'BeforeDestruction')=0) then @@ -12476,109 +12480,6 @@ var Result:=false; end; - procedure AddCallAncestorMemberFunction(ClassContext: TConvertContext; - Ancestor: TPasType; Src: TJSSourceElements; Kind: TMemberFunc); - var - Call: TJSCallExpression; - AncestorPath: String; - begin - if (Ancestor=nil) or AncestorIsExternal then - exit; - Call:=CreateCallExpression(El); - AncestorPath:=CreateReferencePath(Ancestor,ClassContext,rpkPathAndName); - Call.Expr:=CreatePrimitiveDotExpr(AncestorPath+'.'+MemberFuncName[Kind]+'.call',El); - Call.AddArg(CreatePrimitiveDotExpr('this',El)); - AddToSourceElements(Src,Call); - end; - - procedure AddInstanceMemberFunction(Src: TJSSourceElements; - ClassContext: TConvertContext; Ancestor: TPasType; Kind: TMemberFunc); - // add instance initialization function: - // this.$init = function(){ - // ancestor.$init(); - // ... init variables ... - // } - // or add instance finalization function: - // this.$final = function(){ - // ... clear references ... - // ancestor.$final(); - // } - var - FuncVD: TJSVarDeclaration; - New_Src: TJSSourceElements; - New_FuncContext: TFunctionContext; - I: Integer; - P: TPasElement; - NewEl: TJSElement; - Func: TJSFunctionDeclarationStatement; - VarType: TPasType; - AssignSt: TJSSimpleAssignStatement; - begin - // add instance members - New_Src:=TJSSourceElements(CreateElement(TJSSourceElements, El)); - New_FuncContext:=TFunctionContext.Create(El,New_Src,ClassContext); - try - New_FuncContext.ThisPas:=El; - New_FuncContext.IsGlobal:=true; - - // add class members - For I:=0 to El.Members.Count-1 do - begin - P:=TPasElement(El.Members[i]); - if not IsMemberNeeded(P) then continue; - NewEl:=nil; - if (P.ClassType=TPasVariable) - and (ClassVarModifiersType*TPasVariable(P).VarModifiers=[]) then - begin - if Kind=mfInit then - // mfInit: init var - NewEl:=CreateVarDecl(TPasVariable(P),New_FuncContext) // can be nil - else - begin - // mfFinalize: clear reference - if vmExternal in TPasVariable(P).VarModifiers then continue; - VarType:=ClassContext.Resolver.ResolveAliasType(TPasVariable(P).VarType); - if (VarType.ClassType=TPasRecordType) - or (VarType.ClassType=TPasClassType) - or (VarType.ClassType=TPasClassOfType) - or (VarType.ClassType=TPasSetType) - or (VarType.ClassType=TPasProcedureType) - or (VarType.ClassType=TPasFunctionType) - or (VarType.ClassType=TPasArrayType) then - begin - AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); - NewEl:=AssignSt; - AssignSt.LHS:=CreateSubDeclNameExpr(P,New_FuncContext); - AssignSt.Expr:=CreateLiteralUndefined(El); - end; - end; - end; - if NewEl=nil then continue; - if (Kind=mfInit) and (New_Src.Statements.Count=0) then - // add call ancestor.$init.call(this) - AddCallAncestorMemberFunction(ClassContext,Ancestor,New_Src,Kind); - AddToSourceElements(New_Src,NewEl); - end; - if (Kind=mfFinalize) and (New_Src.Statements.Count>0) then - // call ancestor.$final.call(this) - AddCallAncestorMemberFunction(ClassContext,Ancestor,New_Src,Kind); - if (Ancestor<>nil) and (not AncestorIsExternal) - and (New_Src.Statements.Count=0) then - exit; // descendent does not need $init/$final - - FuncVD:=TJSVarDeclaration(CreateElement(TJSVarDeclaration,El)); - AddToSourceElements(Src,FuncVD); - FuncVD.Name:='this.'+MemberFuncName[Kind]; - Func:=CreateFunctionSt(El); - FuncVD.Init:=Func; - Func.AFunction.Body.A:=New_Src; - New_Src:=nil; - finally - New_Src.Free; - New_FuncContext.Free; - end; - end; - procedure AddInterfaceProcNames(Call: TJSCallExpression); var Arr: TJSArrayLiteral; @@ -12596,180 +12497,6 @@ var end; end; - procedure AddMapProcs(Map: TPasClassIntfMap; Call: TJSCallExpression; - var ObjLit: TJSObjectLiteral; FuncContext: TConvertContext); - var - i: Integer; - MapItem: TObject; - Proc, IntfProc: TPasProcedure; - ProcName, IntfProcName: String; - Intf: TPasClassType; - Lit: TJSObjectLiteralElement; - begin - Intf:=Map.Intf; - if Map.Procs<>nil then - for i:=0 to Map.Procs.Count-1 do - begin - MapItem:=TObject(Map.Procs[i]); - if not (MapItem is TPasProcedure) then continue; - Proc:=TPasProcedure(MapItem); - ProcName:=TransformVariableName(Proc,FuncContext); - IntfProc:=TObject(Intf.Members[i]) as TPasProcedure; - IntfProcName:=TransformVariableName(IntfProc,FuncContext); - if IntfProcName=ProcName then continue; - if ObjLit=nil then - begin - ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El)); - Call.AddArg(ObjLit); - end; - Lit:=ObjLit.Elements.AddElement; - Lit.Name:=TJSString(IntfProcName); - Lit.Expr:=CreateLiteralString(El,ProcName); - end; - if Map.AncestorMap<>nil then - AddMapProcs(Map.AncestorMap,Call,ObjLit,FuncContext); - end; - - procedure AddInterfaces(Src: TJSSourceElements; FuncContext: TFunctionContext); - var - Call: TJSCallExpression; - ObjLit: TJSObjectLiteral; - i: Integer; - Scope, CurScope: TPas2JSClassScope; - o: TObject; - IntfMaps: TJSSimpleAssignStatement; - MapsObj: TJSObjectLiteral; - Map: TPasClassIntfMap; - FinishedGUIDs: TStringList; - Intf: TPasType; - CurEl: TPasClassType; - NeedIntfMap, HasInterfaces: Boolean; - begin - HasInterfaces:=false; - NeedIntfMap:=false; - Scope:=TPas2JSClassScope(El.CustomData); - repeat - if Scope.Interfaces<>nil then - begin - for i:=0 to Scope.Interfaces.Count-1 do - begin - CurEl:=TPasClassType(Scope.Element); - if not IsMemberNeeded(TPasElement(CurEl.Interfaces[i])) then continue; - HasInterfaces:=true; - o:=TObject(Scope.Interfaces[i]); - if o is TPasProperty then - // interface delegation -> needs $intfmaps={} - NeedIntfMap:=true; - end; - end; - Scope:=TPas2JSClassScope(Scope.AncestorScope); - until Scope=nil; - if not HasInterfaces then exit; - - IntfMaps:=nil; - FinishedGUIDs:=TStringList.Create; - try - ObjLit:=nil; - Scope:=TPas2JSClassScope(El.CustomData); - repeat - if Scope.Interfaces<>nil then - begin - for i:=0 to Scope.Interfaces.Count-1 do - begin - CurEl:=TPasClassType(Scope.Element); - if not IsMemberNeeded(TPasElement(CurEl.Interfaces[i])) then continue; - if NeedIntfMap then - begin - // add "this.$intfmaps = {};" - IntfMaps:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); - AddToSourceElements(Src,IntfMaps); - IntfMaps.LHS:=CreatePrimitiveDotExpr('this.'+GetBIName(pbivnIntfMaps),El); - MapsObj:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El)); - IntfMaps.Expr:=MapsObj; - NeedIntfMap:=false; - end; - - o:=TObject(Scope.Interfaces[i]); - if o is TPasClassIntfMap then - begin - // add rtl.addIntf(this,intftype,{ intfprocname: "procname", ...}); - Map:=TPasClassIntfMap(o); - Intf:=Map.Intf; - CurScope:=TPas2JSClassScope(Intf.CustomData); - if FinishedGUIDs.IndexOf(CurScope.GUID)>=0 then continue; - FinishedGUIDs.Add(CurScope.GUID); - Call:=CreateCallExpression(El); - AddToSourceElements(Src,Call); - Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnIntfAddMap),El); - Call.AddArg(CreatePrimitiveDotExpr('this',El)); - Call.AddArg(CreateReferencePathExpr(Map.Intf,FuncContext)); - AddMapProcs(Map,Call,ObjLit,FuncContext); - end - else if o is TPasProperty then - AddIntfDelegations(El,TPasProperty(o),FinishedGUIDs,MapsObj,FuncContext) - else - RaiseNotSupported(El,FuncContext,20180326234026,GetObjName(o)); - end; - end; - Scope:=TPas2JSClassScope(Scope.AncestorScope); - until Scope=nil; - finally - FinishedGUIDs.Free; - end; - end; - - procedure AddRTTI(Src: TJSSourceElements; FuncContext: TFunctionContext); - var - HasRTTIMembers: Boolean; - i: Integer; - P: TPasElement; - NewEl: TJSElement; - VarSt: TJSVariableStatement; - C: TClass; - begin - // add $r to local vars, to avoid name clashes and for nicer debugging - FuncContext.AddLocalVar(GetBIName(pbivnRTTILocal),nil); - - HasRTTIMembers:=false; - For i:=0 to El.Members.Count-1 do - begin - P:=TPasElement(El.Members[i]); - //writeln('TPasToJSConverter.ConvertClassType RTTI El[',i,']=',GetObjName(P)); - if El.ObjKind=okInterface then - // all interface methods are published - else if P.Visibility<>visPublished then - continue; - if not IsMemberNeeded(P) then continue; - NewEl:=nil; - C:=P.ClassType; - if C=TPasVariable then - NewEl:=CreateRTTIMemberField(TPasVariable(P),FuncContext) - else if C.InheritsFrom(TPasProcedure) then - NewEl:=CreateRTTIMemberMethod(TPasProcedure(P),FuncContext) - else if C=TPasProperty then - NewEl:=CreateRTTIMemberProperty(TPasProperty(P),FuncContext) - else if C.InheritsFrom(TPasType) then - continue - else if C=TPasMethodResolution then - continue - else - DoError(20170409202315,nSymbolCannotBePublished,sSymbolCannotBePublished,[],P); - if NewEl=nil then - continue; // e.g. abstract or external proc - // add RTTI element - if not HasRTTIMembers then - begin - // add "var $r = this.$rtti" - VarSt:=CreateVarStatement(GetBIName(pbivnRTTILocal), - CreateMemberExpression(['this',GetBIName(pbivnRTTI)]),El); - AddToSourceElements(Src,VarSt); - - HasRTTIMembers:=true; - end; - AddToSourceElements(Src,NewEl); - end; - end; - var Call: TJSCallExpression; FunDecl: TJSFunctionDeclarationStatement; @@ -12784,7 +12511,7 @@ var AncestorPath, OwnerName, DestructorName, FnName, IntfKind: String; C: TClass; AssignSt: TJSSimpleAssignStatement; - NeedInitFunction: Boolean; + NeedInitFunction, HasConstructor: Boolean; begin Result:=nil; {$IFDEF VerbosePas2JS} @@ -12954,13 +12681,14 @@ begin if El.ObjKind in [okClass] then begin // instance initialization function - AddInstanceMemberFunction(Src,FuncContext,Ancestor,mfInit); + AddInstanceMemberFunction(El,Src,FuncContext,IsTObject,Ancestor,mfInit); // instance finalization function - AddInstanceMemberFunction(Src,FuncContext,Ancestor,mfFinalize); + AddInstanceMemberFunction(El,Src,FuncContext,IsTObject,Ancestor,mfFinalize); end; if El.ObjKind in ([okClass]+okAllHelpers) then begin + HasConstructor:=false; // add method implementations For i:=0 to El.Members.Count-1 do begin @@ -12980,7 +12708,9 @@ begin AssignSt.Expr:=CreateLiteralString(P,DestructorName); AddToSourceElements(Src,AssignSt); end; - end; + end + else if C.ClassType=TPasConstructor then + HasConstructor:=true; NewEl:=ConvertProcedure(TPasProcedure(P),FuncContext); end else @@ -12989,15 +12719,17 @@ begin continue; // e.g. abstract or external proc AddToSourceElements(Src,NewEl); end; + if HasConstructor and (El.HelperForType<>nil) then + AddHelperConstructor(El,Src,FuncContext); end; // add interfaces if (El.ObjKind=okClass) and (AContext.Resolver<>nil) then - AddInterfaces(Src,FuncContext); + AddClassSupportedInterfaces(El,Src,FuncContext); // add RTTI init function if AContext.Resolver<>nil then - AddRTTI(Src,FuncContext); + AddClassRTTI(El,Src,FuncContext); end;// end of init function @@ -15431,6 +15163,193 @@ begin end; end; +procedure TPasToJSConverter.AddInstanceMemberFunction(El: TPasClassType; + Src: TJSSourceElements; ClassContext: TConvertContext; IsTObject: boolean; + Ancestor: TPasType; Kind: TMemberFunc); +const + MemberFuncName: array[TMemberFunc] of string = ( + '$init', + '$final' + ); +var + AncestorIsExternal: boolean; + + function IsMemberNeeded(aMember: TPasElement): boolean; + begin + if IsElementUsed(aMember) then exit(true); + if IsTObject then + begin + if aMember.ClassType=TPasProcedure then + begin + if (CompareText(aMember.Name,'AfterConstruction')=0) + or (CompareText(aMember.Name,'BeforeDestruction')=0) then + exit(true); + end; + end; + Result:=false; + end; + + procedure AddCallAncestorMemberFunction(ClassContext: TConvertContext; + Ancestor: TPasType; Src: TJSSourceElements; Kind: TMemberFunc); + var + Call: TJSCallExpression; + AncestorPath: String; + begin + if (Ancestor=nil) or AncestorIsExternal then + exit; + Call:=CreateCallExpression(El); + AncestorPath:=CreateReferencePath(Ancestor,ClassContext,rpkPathAndName); + Call.Expr:=CreatePrimitiveDotExpr(AncestorPath+'.'+MemberFuncName[Kind]+'.call',El); + Call.AddArg(CreatePrimitiveDotExpr('this',El)); + AddToSourceElements(Src,Call); + end; + +// add instance initialization function: +// this.$init = function(){ +// ancestor.$init(); +// ... init variables ... +// } +// or add instance finalization function: +// this.$final = function(){ +// ... clear references ... +// ancestor.$final(); +// } +var + FuncVD: TJSVarDeclaration; + New_Src: TJSSourceElements; + New_FuncContext: TFunctionContext; + I: Integer; + P: TPasElement; + NewEl: TJSElement; + Func: TJSFunctionDeclarationStatement; + VarType: TPasType; + AssignSt: TJSSimpleAssignStatement; +begin + // add instance members + AncestorIsExternal:=(Ancestor is TPasClassType) and TPasClassType(Ancestor).IsExternal; + New_Src:=TJSSourceElements(CreateElement(TJSSourceElements, El)); + New_FuncContext:=TFunctionContext.Create(El,New_Src,ClassContext); + try + New_FuncContext.ThisPas:=El; + New_FuncContext.IsGlobal:=true; + + // add class members + For I:=0 to El.Members.Count-1 do + begin + P:=TPasElement(El.Members[i]); + if not IsMemberNeeded(P) then continue; + NewEl:=nil; + if (P.ClassType=TPasVariable) + and (ClassVarModifiersType*TPasVariable(P).VarModifiers=[]) then + begin + if Kind=mfInit then + // mfInit: init var + NewEl:=CreateVarDecl(TPasVariable(P),New_FuncContext) // can be nil + else + begin + // mfFinalize: clear reference + if vmExternal in TPasVariable(P).VarModifiers then continue; + VarType:=ClassContext.Resolver.ResolveAliasType(TPasVariable(P).VarType); + if (VarType.ClassType=TPasRecordType) + or (VarType.ClassType=TPasClassType) + or (VarType.ClassType=TPasClassOfType) + or (VarType.ClassType=TPasSetType) + or (VarType.ClassType=TPasProcedureType) + or (VarType.ClassType=TPasFunctionType) + or (VarType.ClassType=TPasArrayType) then + begin + AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); + NewEl:=AssignSt; + AssignSt.LHS:=CreateSubDeclNameExpr(P,New_FuncContext); + AssignSt.Expr:=CreateLiteralUndefined(El); + end; + end; + end; + if NewEl=nil then continue; + if (Kind=mfInit) and (New_Src.Statements.Count=0) then + // add call ancestor.$init.call(this) + AddCallAncestorMemberFunction(ClassContext,Ancestor,New_Src,Kind); + AddToSourceElements(New_Src,NewEl); + end; + if (Kind=mfFinalize) and (New_Src.Statements.Count>0) then + // call ancestor.$final.call(this) + AddCallAncestorMemberFunction(ClassContext,Ancestor,New_Src,Kind); + if (Ancestor<>nil) and (not AncestorIsExternal) + and (New_Src.Statements.Count=0) then + exit; // descendent does not need $init/$final + + FuncVD:=TJSVarDeclaration(CreateElement(TJSVarDeclaration,El)); + AddToSourceElements(Src,FuncVD); + FuncVD.Name:='this.'+MemberFuncName[Kind]; + Func:=CreateFunctionSt(El); + FuncVD.Init:=Func; + Func.AFunction.Body.A:=New_Src; + New_Src:=nil; + finally + New_Src.Free; + New_FuncContext.Free; + end; +end; + +procedure TPasToJSConverter.AddClassRTTI(El: TPasClassType; + Src: TJSSourceElements; FuncContext: TFunctionContext); + + function IsMemberNeeded(aMember: TPasElement): boolean; + begin + Result:=IsElementUsed(aMember); + end; + +var + HasRTTIMembers: Boolean; + i: Integer; + P: TPasElement; + NewEl: TJSElement; + VarSt: TJSVariableStatement; + C: TClass; +begin + // add $r to local vars, to avoid name clashes and for nicer debugging + FuncContext.AddLocalVar(GetBIName(pbivnRTTILocal),nil); + + HasRTTIMembers:=false; + For i:=0 to El.Members.Count-1 do + begin + P:=TPasElement(El.Members[i]); + //writeln('TPasToJSConverter.ConvertClassType RTTI El[',i,']=',GetObjName(P)); + if El.ObjKind=okInterface then + // all interface methods are published + else if P.Visibility<>visPublished then + continue; + if not IsMemberNeeded(P) then continue; + NewEl:=nil; + C:=P.ClassType; + if C=TPasVariable then + NewEl:=CreateRTTIMemberField(TPasVariable(P),FuncContext) + else if C.InheritsFrom(TPasProcedure) then + NewEl:=CreateRTTIMemberMethod(TPasProcedure(P),FuncContext) + else if C=TPasProperty then + NewEl:=CreateRTTIMemberProperty(TPasProperty(P),FuncContext) + else if C.InheritsFrom(TPasType) then + continue + else if C=TPasMethodResolution then + continue + else + DoError(20170409202315,nSymbolCannotBePublished,sSymbolCannotBePublished,[],P); + if NewEl=nil then + continue; // e.g. abstract or external proc + // add RTTI element + if not HasRTTIMembers then + begin + // add "var $r = this.$rtti" + VarSt:=CreateVarStatement(GetBIName(pbivnRTTILocal), + CreateMemberExpression(['this',GetBIName(pbivnRTTI)]),El); + AddToSourceElements(Src,VarSt); + + HasRTTIMembers:=true; + end; + AddToSourceElements(Src,NewEl); + end; +end; + function TPasToJSConverter.CreateCallback(Expr: TPasExpr; ResolvedEl: TPasResolverResult; AContext: TConvertContext): TJSElement; // El is a reference to a proc @@ -16934,6 +16853,136 @@ begin end; end; +procedure TPasToJSConverter.AddClassSupportedInterfaces(El: TPasClassType; + Src: TJSSourceElements; FuncContext: TFunctionContext); + + function IsMemberNeeded(aMember: TPasElement): boolean; + begin + if IsElementUsed(aMember) then exit(true); + Result:=false; + end; + + procedure AddMapProcs(Map: TPasClassIntfMap; Call: TJSCallExpression; + var ObjLit: TJSObjectLiteral; FuncContext: TConvertContext); + var + i: Integer; + MapItem: TObject; + Proc, IntfProc: TPasProcedure; + ProcName, IntfProcName: String; + Intf: TPasClassType; + Lit: TJSObjectLiteralElement; + begin + Intf:=Map.Intf; + if Map.Procs<>nil then + for i:=0 to Map.Procs.Count-1 do + begin + MapItem:=TObject(Map.Procs[i]); + if not (MapItem is TPasProcedure) then continue; + Proc:=TPasProcedure(MapItem); + ProcName:=TransformVariableName(Proc,FuncContext); + IntfProc:=TObject(Intf.Members[i]) as TPasProcedure; + IntfProcName:=TransformVariableName(IntfProc,FuncContext); + if IntfProcName=ProcName then continue; + if ObjLit=nil then + begin + ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El)); + Call.AddArg(ObjLit); + end; + Lit:=ObjLit.Elements.AddElement; + Lit.Name:=TJSString(IntfProcName); + Lit.Expr:=CreateLiteralString(El,ProcName); + end; + if Map.AncestorMap<>nil then + AddMapProcs(Map.AncestorMap,Call,ObjLit,FuncContext); + end; + +var + Call: TJSCallExpression; + ObjLit: TJSObjectLiteral; + i: Integer; + Scope, CurScope: TPas2JSClassScope; + o: TObject; + IntfMaps: TJSSimpleAssignStatement; + MapsObj: TJSObjectLiteral; + Map: TPasClassIntfMap; + FinishedGUIDs: TStringList; + Intf: TPasType; + CurEl: TPasClassType; + NeedIntfMap, HasInterfaces: Boolean; +begin + HasInterfaces:=false; + NeedIntfMap:=false; + Scope:=TPas2JSClassScope(El.CustomData); + repeat + if Scope.Interfaces<>nil then + begin + for i:=0 to Scope.Interfaces.Count-1 do + begin + CurEl:=TPasClassType(Scope.Element); + if not IsMemberNeeded(TPasElement(CurEl.Interfaces[i])) then continue; + HasInterfaces:=true; + o:=TObject(Scope.Interfaces[i]); + if o is TPasProperty then + // interface delegation -> needs $intfmaps={} + NeedIntfMap:=true; + end; + end; + Scope:=TPas2JSClassScope(Scope.AncestorScope); + until Scope=nil; + if not HasInterfaces then exit; + + IntfMaps:=nil; + FinishedGUIDs:=TStringList.Create; + try + ObjLit:=nil; + Scope:=TPas2JSClassScope(El.CustomData); + repeat + if Scope.Interfaces<>nil then + begin + for i:=0 to Scope.Interfaces.Count-1 do + begin + CurEl:=TPasClassType(Scope.Element); + if not IsMemberNeeded(TPasElement(CurEl.Interfaces[i])) then continue; + if NeedIntfMap then + begin + // add "this.$intfmaps = {};" + IntfMaps:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); + AddToSourceElements(Src,IntfMaps); + IntfMaps.LHS:=CreatePrimitiveDotExpr('this.'+GetBIName(pbivnIntfMaps),El); + MapsObj:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El)); + IntfMaps.Expr:=MapsObj; + NeedIntfMap:=false; + end; + + o:=TObject(Scope.Interfaces[i]); + if o is TPasClassIntfMap then + begin + // add rtl.addIntf(this,intftype,{ intfprocname: "procname", ...}); + Map:=TPasClassIntfMap(o); + Intf:=Map.Intf; + CurScope:=TPas2JSClassScope(Intf.CustomData); + if FinishedGUIDs.IndexOf(CurScope.GUID)>=0 then continue; + FinishedGUIDs.Add(CurScope.GUID); + Call:=CreateCallExpression(El); + AddToSourceElements(Src,Call); + Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnIntfAddMap),El); + Call.AddArg(CreatePrimitiveDotExpr('this',El)); + Call.AddArg(CreateReferencePathExpr(Map.Intf,FuncContext)); + AddMapProcs(Map,Call,ObjLit,FuncContext); + end + else if o is TPasProperty then + AddIntfDelegations(El,TPasProperty(o),FinishedGUIDs,MapsObj,FuncContext) + else + RaiseNotSupported(El,FuncContext,20180326234026,GetObjName(o)); + end; + end; + Scope:=TPas2JSClassScope(Scope.AncestorScope); + until Scope=nil; + finally + FinishedGUIDs.Free; + end; +end; + function TPasToJSConverter.CreateCallHelperMethod(Proc: TPasProcedure; Expr: TPasExpr; AContext: TConvertContext; Implicit: boolean ): TJSCallExpression; @@ -17287,6 +17336,77 @@ begin end; end; +procedure TPasToJSConverter.AddHelperConstructor(El: TPasClassType; + Src: TJSSourceElements; AContext: TConvertContext); +const + FunName = 'fn'; + ArgsName = 'args'; +var + aResolver: TPas2JSResolver; + HelperForType: TPasType; + AssignSt: TJSSimpleAssignStatement; + Func: TJSFunctionDeclarationStatement; + New_Src: TJSSourceElements; + Call: TJSCallExpression; + DotExpr: TJSDotMemberExpression; + BracketExpr: TJSBracketMemberExpression; + New_FuncContext: TFunctionContext; + Init: TJSElement; + ReturnSt: TJSReturnStatement; +begin + if El.HelperForType=nil then exit; + aResolver:=AContext.Resolver; + HelperForType:=aResolver.ResolveAliasType(El.HelperForType); + if HelperForType.ClassType=TPasClassType then + exit; // a class helper does not need a special sub function + + New_Src:=TJSSourceElements(CreateElement(TJSSourceElements, El)); + New_FuncContext:=TFunctionContext.Create(El,New_Src,AContext); + try + New_FuncContext.ThisPas:=El; + New_FuncContext.IsGlobal:=true; + + if HelperForType.ClassType=TPasRecordType then + begin + // record helper + // Note: a newinstance call looks like this: THelper.$new("NewHlp", [3]); + // The $new function: + // this.$new = function(fnname,args){ + // return this[fnname].call(TRecType.$new(),args); + // } + ReturnSt:=TJSReturnStatement(CreateElement(TJSReturnStatement,El)); + AddToSourceElements(New_Src,ReturnSt); + Call:=CreateCallExpression(El); + ReturnSt.Expr:=Call; + DotExpr:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,El)); + Call.Expr:=DotExpr; + BracketExpr:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El)); + DotExpr.MExpr:=BracketExpr; + DotExpr.Name:='call'; + BracketExpr.MExpr:=CreatePrimitiveDotExpr('this',El); + BracketExpr.Name:=CreatePrimitiveDotExpr(FunName,El); + Init:=CreateValInit(HelperForType,nil,El,New_FuncContext); + Call.AddArg(Init); + Call.AddArg(CreatePrimitiveDotExpr(ArgsName,El)); + end + else + RaiseNotSupported(El,AContext,20190208181800); + // this.$new = function(fnname,args){ + AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); + AddToSourceElements(Src,AssignSt); + AssignSt.LHS:=CreatePrimitiveDotExpr('this.'+GetBIName(pbifnHelperNew),El); + Func:=CreateFunctionSt(El); + AssignSt.Expr:=Func; + Func.AFunction.Params.Add(FunName); + Func.AFunction.Params.Add(ArgsName); + Func.AFunction.Body.A:=New_Src; + New_Src:=nil; + finally + New_Src.Free; + New_FuncContext.Free; + end; +end; + function TPasToJSConverter.ConvertImplBlock(El: TPasImplBlock; AContext: TConvertContext): TJSElement; begin diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 705e7e62ef..10c423694c 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -645,11 +645,11 @@ type Procedure TestClassHelper_ClassPropertyStatic; Procedure TestClassHelper_ClassProperty_Array; Procedure TestClassHelper_ForIn; - // todo: TestRecordHelper_ClassVar - // todo: TestRecordHelper_Method - // todo: TestRecordHelper_ClassMethod - // todo: TestRecordHelper_NestedMethod - // todo: TestRecorHelper_Constructor; + Procedure TestExtClassHelper_ClassVar; + Procedure TestExtClassHelper_Method_Call; + Procedure TestRecordHelper_ClassVar; + Procedure TestRecordHelper_Method_Call; + Procedure TestRecorHelper_Constructor; // todo: TestRecordHelper_Args // todo: TestRecordHelper_Property // todo: TestRecordHelper_Property_Array @@ -18643,7 +18643,7 @@ begin ' end;', '']); ConvertProgram; - CheckSource('TestClassHelper', + CheckSource('TestClassHelper_ClassVar', LinesToStr([ // statements 'rtl.createClass($mod, "TObject", null, function () {', ' this.$init = function () {', @@ -20337,6 +20337,441 @@ begin ''])); end; +procedure TTestModule.TestExtClassHelper_ClassVar; +begin + StartProgram(false); + Add([ + '{$modeswitch externalclass}', + 'type', + ' TExtA = class external name ''ExtObj''', + ' end;', + ' THelper = class helper for TExtA', + ' const', + ' One = 1;', + ' Two: word = 2;', + ' class var', + ' Glob: word;', + ' function Foo(w: word): word;', + ' class function Bar(w: word): word; static;', + ' end;', + 'function THelper.foo(w: word): word;', + 'begin', + ' Result:=w;', + ' Two:=One+w;', + ' Glob:=Glob;', + ' Result:=Self.Glob;', + ' Self.Glob:=Self.Glob;', + ' with Self do Glob:=Glob;', + 'end;', + 'class function THelper.bar(w: word): word;', + 'begin', + ' Result:=w;', + ' Two:=One;', + ' Glob:=Glob;', + 'end;', + 'var o: TExtA;', + 'begin', + ' texta.two:=texta.one;', + ' texta.Glob:=texta.Glob;', + ' with texta do begin', + ' two:=one;', + ' Glob:=Glob;', + ' end;', + ' o.two:=o.one;', + ' o.Glob:=o.Glob;', + ' with o do begin', + ' two:=one;', + ' Glob:=Glob;', + ' end;', + '']); + ConvertProgram; + CheckSource('TestExtClassHelper_ClassVar', + LinesToStr([ // statements + 'rtl.createHelper($mod, "THelper", null, function () {', + ' this.One = 1;', + ' this.Two = 2;', + ' this.Glob = 0;', + ' this.Foo = function (w) {', + ' var Result = 0;', + ' Result = w;', + ' $mod.THelper.Two = 1 + w;', + ' $mod.THelper.Glob = $mod.THelper.Glob;', + ' Result = $mod.THelper.Glob;', + ' $mod.THelper.Glob = $mod.THelper.Glob;', + ' $mod.THelper.Glob = $mod.THelper.Glob;', + ' return Result;', + ' };', + ' this.Bar = function (w) {', + ' var Result = 0;', + ' Result = w;', + ' $mod.THelper.Two = 1;', + ' $mod.THelper.Glob = $mod.THelper.Glob;', + ' return Result;', + ' };', + '});', + 'this.o = null;', + '']), + LinesToStr([ // $mod.$main + '$mod.THelper.Two = 1;', + '$mod.THelper.Glob = $mod.THelper.Glob;', + '$mod.THelper.Two = 1;', + '$mod.THelper.Glob = $mod.THelper.Glob;', + '$mod.THelper.Two = 1;', + '$mod.THelper.Glob = $mod.THelper.Glob;', + 'var $with1 = $mod.o;', + '$mod.THelper.Two = 1;', + '$mod.THelper.Glob = $mod.THelper.Glob;', + ''])); +end; + +procedure TTestModule.TestExtClassHelper_Method_Call; +begin + StartProgram(false); + Add([ + '{$modeswitch externalclass}', + 'type', + ' TExtA = class external name ''ExtObj''', + ' procedure Run(w: word = 10);', + ' end;', + ' THelper = class helper for TExtA', + ' function Foo(w: word = 1): word;', + ' end;', + 'function THelper.foo(w: word): word;', + 'begin', + ' Run;', + ' Run();', + ' Run(11);', + ' Foo;', + ' Foo();', + ' Foo(12);', + ' Self.Foo;', + ' Self.Foo();', + ' Self.Foo(13);', + ' with Self do begin', + ' Foo;', + ' Foo();', + ' Foo(14);', + ' end;', + 'end;', + 'var Obj: TExtA;', + 'begin', + ' obj.Foo;', + ' obj.Foo();', + ' obj.Foo(21);', + ' with obj do begin', + ' Foo;', + ' Foo();', + ' Foo(22);', + ' end;', + '']); + ConvertProgram; + CheckSource('TestExtClassHelper_Method_Call', + LinesToStr([ // statements + 'rtl.createHelper($mod, "THelper", null, function () {', + ' this.Foo = function (w) {', + ' var Result = 0;', + ' this.Run(10);', + ' this.Run(10);', + ' this.Run(11);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 12);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 13);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 14);', + ' return Result;', + ' };', + '});', + 'this.Obj = null;', + '']), + LinesToStr([ // $mod.$main + '$mod.THelper.Foo.apply($mod.Obj, 1);', + '$mod.THelper.Foo.apply($mod.Obj, 1);', + '$mod.THelper.Foo.apply($mod.Obj, 21);', + 'var $with1 = $mod.Obj;', + '$mod.THelper.Foo.apply($with1, 1);', + '$mod.THelper.Foo.apply($with1, 1);', + '$mod.THelper.Foo.apply($with1, 22);', + ''])); +end; + +procedure TTestModule.TestRecordHelper_ClassVar; +begin + StartProgram(false); + Add([ + 'type', + ' TRec = record', + ' end;', + ' THelper = record helper for TRec', + ' const', + ' One = 1;', + ' Two: word = 2;', + ' class var', + ' Glob: word;', + ' function Foo(w: word): word;', + ' class function Bar(w: word): word; static;', + ' end;', + 'function THelper.foo(w: word): word;', + 'begin', + ' Result:=w;', + ' Two:=One+w;', + ' Glob:=Glob;', + ' Result:=Self.Glob;', + ' Self.Glob:=Self.Glob;', + ' with Self do Glob:=Glob;', + 'end;', + 'class function THelper.bar(w: word): word;', + 'begin', + ' Result:=w;', + ' Two:=One;', + ' Glob:=Glob;', + 'end;', + 'var r: TRec;', + 'begin', + ' trec.two:=trec.one;', + ' trec.Glob:=trec.Glob;', + ' with trec do begin', + ' two:=one;', + ' Glob:=Glob;', + ' end;', + ' r.two:=r.one;', + ' r.Glob:=r.Glob;', + ' with r do begin', + ' two:=one;', + ' Glob:=Glob;', + ' end;', + '']); + ConvertProgram; + CheckSource('TestRecordHelper_ClassVar', + LinesToStr([ // statements + 'rtl.recNewT($mod, "TRec", function () {', + ' this.$eq = function (b) {', + ' return true;', + ' };', + ' this.$assign = function (s) {', + ' return this;', + ' };', + '});', + 'rtl.createHelper($mod, "THelper", null, function () {', + ' this.One = 1;', + ' this.Two = 2;', + ' this.Glob = 0;', + ' this.Foo = function (w) {', + ' var Result = 0;', + ' Result = w;', + ' $mod.THelper.Two = 1 + w;', + ' $mod.THelper.Glob = $mod.THelper.Glob;', + ' Result = $mod.THelper.Glob;', + ' $mod.THelper.Glob = $mod.THelper.Glob;', + ' $mod.THelper.Glob = $mod.THelper.Glob;', + ' return Result;', + ' };', + ' this.Bar = function (w) {', + ' var Result = 0;', + ' Result = w;', + ' $mod.THelper.Two = 1;', + ' $mod.THelper.Glob = $mod.THelper.Glob;', + ' return Result;', + ' };', + '});', + 'this.r = $mod.TRec.$new();', + '']), + LinesToStr([ // $mod.$main + '$mod.THelper.Two = 1;', + '$mod.THelper.Glob = $mod.THelper.Glob;', + 'var $with1 = $mod.TRec;', + '$mod.THelper.Two = 1;', + '$mod.THelper.Glob = $mod.THelper.Glob;', + '$mod.THelper.Two = 1;', + '$mod.THelper.Glob = $mod.THelper.Glob;', + 'var $with2 = $mod.r;', + '$mod.THelper.Two = 1;', + '$mod.THelper.Glob = $mod.THelper.Glob;', + ''])); +end; + +procedure TTestModule.TestRecordHelper_Method_Call; +begin + StartProgram(false); + Add([ + '{$modeswitch AdvancedRecords}', + 'type', + ' TRec = record', + ' procedure Run(w: word = 10);', + ' end;', + ' THelper = record helper for TRec', + ' function Foo(w: word = 1): word;', + ' end;', + 'procedure TRec.Run(w: word);', + 'begin', + ' Foo;', + ' Foo();', + ' Foo(2);', + ' Self.Foo;', + ' Self.Foo();', + ' Self.Foo(3);', + ' with Self do begin', + ' Foo;', + ' Foo();', + ' Foo(4);', + ' end;', + 'end;', + 'function THelper.foo(w: word): word;', + 'begin', + ' Run;', + ' Run();', + ' Run(11);', + ' Foo;', + ' Foo();', + ' Foo(12);', + ' Self.Foo;', + ' Self.Foo();', + ' Self.Foo(13);', + ' with Self do begin', + ' Foo;', + ' Foo();', + ' Foo(14);', + ' end;', + 'end;', + 'var Rec: TRec;', + 'begin', + ' Rec.Foo;', + ' Rec.Foo();', + ' Rec.Foo(21);', + ' with Rec do begin', + ' Foo;', + ' Foo();', + ' Foo(22);', + ' end;', + '']); + ConvertProgram; + CheckSource('TestRecordHelper_Method_Call', + LinesToStr([ // statements + 'rtl.recNewT($mod, "TRec", function () {', + ' this.$eq = function (b) {', + ' return true;', + ' };', + ' this.$assign = function (s) {', + ' return this;', + ' };', + ' this.Run = function (w) {', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 2);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 3);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 4);', + ' };', + '});', + 'rtl.createHelper($mod, "THelper", null, function () {', + ' this.Foo = function (w) {', + ' var Result = 0;', + ' this.Run(10);', + ' this.Run(10);', + ' this.Run(11);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 12);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 13);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 1);', + ' $mod.THelper.Foo.apply(this, 14);', + ' return Result;', + ' };', + '});', + 'this.Rec = $mod.TRec.$new();', + '']), + LinesToStr([ // $mod.$main + '$mod.THelper.Foo.apply($mod.Rec, 1);', + '$mod.THelper.Foo.apply($mod.Rec, 1);', + '$mod.THelper.Foo.apply($mod.Rec, 21);', + 'var $with1 = $mod.Rec;', + '$mod.THelper.Foo.apply($with1, 1);', + '$mod.THelper.Foo.apply($with1, 1);', + '$mod.THelper.Foo.apply($with1, 22);', + ''])); +end; + +procedure TTestModule.TestRecorHelper_Constructor; +begin + StartProgram(false); + Add([ + '{$modeswitch AdvancedRecords}', + 'type', + ' TRec = record', + ' constructor Create(w: word);', + ' end;', + ' THelper = record helper for TRec', + ' constructor NewHlp(w: word);', + ' end;', + 'var', + ' Rec: TRec;', + 'constructor TRec.Create(w: word);', + 'begin', + ' NewHlp(2);', // normal call + ' trec.NewHlp(3);', // new instance + 'end;', + 'constructor THelper.NewHlp(w: word);', + 'begin', + ' create(2);', // normal call + ' trec.create(3);', // new instance + ' NewHlp(4);', // normal call + ' trec.NewHlp(5);', // new instance + 'end;', + 'begin', + ' rec.newhlp(2);', // normal call + ' with rec do newhlp(12);', // normal call + ' trec.newhlp(3);', // new instance + ' with trec do newhlp(13);', // new instance + '']); + ConvertProgram; + CheckSource('TestRecordHelper_Constructor', + LinesToStr([ // statements + 'rtl.recNewT($mod, "TRec", function () {', + ' this.$eq = function (b) {', + ' return true;', + ' };', + ' this.$assign = function (s) {', + ' return this;', + ' };', + ' this.Create = function (w) {', + ' $mod.THelper.NewHlp.apply(this, 2);', + ' $mod.THelper.$new("NewHlp", [3]);', + ' return this;', + ' };', + '}, true);', + 'rtl.createHelper($mod, "THelper", null, function () {', + ' this.NewHlp = function (w) {', + ' this.Create(2);', + ' $mod.TRec.$create("Create", [3]);', + ' $mod.THelper.NewHlp.apply(this, 4);', + ' $mod.THelper.$new("NewHlp", [5]);', + ' return this;', + ' };', + ' this.$new = function (fn, args) {', + ' return this[fn].call($mod.TRec.$new(), args);', + ' };', + '});', + 'this.Rec = $mod.TRec.$new();', + '']), + LinesToStr([ // $mod.$main + '$mod.THelper.NewHlp.apply($mod.Rec, 2);', + 'var $with1 = $mod.Rec;', + '$mod.THelper.NewHlp.apply($with1, 12);', + '$mod.THelper.$new("NewHlp", [3]);', + 'var $with2 = $mod.TRec;', + '$mod.THelper.$new("NewHlp", [13]);', + ''])); +end; + procedure TTestModule.TestProcType; begin StartProgram(false);