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

pastojs: nested classes

Browse Source 
git-svn-id: trunk@38878 -
This commit is contained in:
Mattias Gaertner 2018-04-30 18:03:48 +00:00
parent ee8896b988
commit 8100f9b222
3 changed files with 303 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2308,8 +2308,6 @@ end;
procedure TPas2JSResolver.AddType(El: TPasType);
begin
inherited AddType(El);
if (El.Name<>'') and (TopScope is TPasClassScope) then
RaiseNotYetImplemented(20170608232534,El,'nested types');
end;
procedure TPas2JSResolver.ResolveImplAsm(El: TPasImplAsmStatement);
@ -4446,7 +4444,11 @@ begin
else if ThisPas=El then
Result:='this'
else
begin
Result:=inherited GetLocalName(El);
if Result='this' then
Result:='';
end;
end;
function TFunctionContext.IndexOfLocalVar(const aName: string): integer;
@ -4636,17 +4638,23 @@ end;
procedure TConvertContext.WriteStack;
{AllowWriteln}
var
SelfCtx: TFunctionContext;
procedure W(Index: integer; AContext: TConvertContext);
begin
if AContext=SelfCtx then
writeln(' SelfContext:');
AContext.DoWriteStack(Index);
if AContext.Parent<>nil then
W(Index+1,AContext.Parent);
end;
begin
writeln('TConvertContext.WriteStack: ');
SelfCtx:=GetSelfContext;
writeln('TConvertContext.WriteStack: START');
W(1,Self);
writeln('TConvertContext.WriteStack: END');
end;
{AllowWriteln-}
@ -10683,10 +10691,12 @@ begin
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FnName]);
// add parameter: owner. For top level class, the module is the owner.
if (El.Parent<>nil) and (El.Parent.ClassType=TImplementationSection) then
OwnerName:=AContext.GetLocalName(El.Parent)
if (El.Parent=nil)
or ((El.Parent is TPasSection)
and (El.Parent.ClassType<>TImplementationSection)) then
OwnerName:=AContext.GetLocalName(El.GetModule)
else
OwnerName:=AContext.GetLocalName(El.GetModule);
OwnerName:=AContext.GetLocalName(El.Parent);
if OwnerName='' then
OwnerName:='this';
Call.AddArg(CreatePrimitiveDotExpr(OwnerName,El));
@ -10782,10 +10792,7 @@ begin
else if C=TPasConst then
NewEl:=ConvertConst(TPasConst(P),aContext)
else if C=TPasProperty then
begin
NewEl:=ConvertProperty(TPasProperty(P),AContext);
if NewEl=nil then continue;
end
NewEl:=ConvertProperty(TPasProperty(P),AContext)
else if C.InheritsFrom(TPasType) then
NewEl:=CreateTypeDecl(TPasType(P),aContext)
else if C.InheritsFrom(TPasProcedure) then
@ -10794,9 +10801,8 @@ begin
continue
else
RaiseNotSupported(P,FuncContext,20161221233338);
if NewEl=nil then
RaiseNotSupported(P,FuncContext,20170204223922);
AddToSourceElements(Src,NewEl);
if NewEl<>nil then
AddToSourceElements(Src,NewEl);
end;
end;
@ -11810,35 +11816,40 @@ begin
if ProcScope.ClassScope<>nil then
begin
// method or class method
FuncContext.ThisPas:=ProcScope.ClassScope.Element;
if bsObjectChecks in FuncContext.ScannerBoolSwitches then
if El.Parent is TProcedureBody then
begin
// rtl.checkMethodCall(this,<class>)
Call:=CreateCallExpression(PosEl);
AddBodyStatement(Call,PosEl);
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],
FBuiltInNames[pbifnCheckMethodCall]]);
Call.AddArg(CreatePrimitiveDotExpr('this',PosEl));
ClassPath:=CreateReferencePath(ProcScope.ClassScope.Element,AContext,rpkPathAndName);
Call.AddArg(CreatePrimitiveDotExpr(ClassPath,PosEl));
end;
if ImplProc.Body.Functions.Count>0 then
begin
// has nested procs -> add "var self = this;"
FuncContext.AddLocalVar(FBuiltInNames[pbivnSelf],FuncContext.ThisPas);
SelfSt:=CreateVarStatement(FBuiltInNames[pbivnSelf],
CreatePrimitiveDotExpr('this',ImplProc),ImplProc);
AddBodyStatement(SelfSt,PosEl);
if ImplProcScope.SelfArg<>nil then
begin
// redirect Pascal-Self to JS-Self
FuncContext.AddLocalVar(FBuiltInNames[pbivnSelf],ImplProcScope.SelfArg);
end;
// nested sub procedure -> no 'this'
FuncContext.ThisPas:=nil;
end
else
begin
if ImplProcScope.SelfArg<>nil then
FuncContext.ThisPas:=ProcScope.ClassScope.Element;
if bsObjectChecks in FuncContext.ScannerBoolSwitches then
begin
// rtl.checkMethodCall(this,<class>)
Call:=CreateCallExpression(PosEl);
AddBodyStatement(Call,PosEl);
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],
FBuiltInNames[pbifnCheckMethodCall]]);
Call.AddArg(CreatePrimitiveDotExpr('this',PosEl));
ClassPath:=CreateReferencePath(ProcScope.ClassScope.Element,AContext,rpkPathAndName);
Call.AddArg(CreatePrimitiveDotExpr(ClassPath,PosEl));
end;
if ImplProc.Body.Functions.Count>0 then
begin
// has nested procs -> add "var self = this;"
FuncContext.AddLocalVar(FBuiltInNames[pbivnSelf],FuncContext.ThisPas);
SelfSt:=CreateVarStatement(FBuiltInNames[pbivnSelf],
CreatePrimitiveDotExpr('this',ImplProc),ImplProc);
AddBodyStatement(SelfSt,PosEl);
if ImplProcScope.SelfArg<>nil then
begin
// redirect Pascal-Self to JS-Self
FuncContext.AddLocalVar(FBuiltInNames[pbivnSelf],ImplProcScope.SelfArg);
end;
end
else if ImplProcScope.SelfArg<>nil then
begin
// no nested procs -> redirect Pascal-Self to JS-this
FuncContext.AddLocalVar('this',ImplProcScope.SelfArg);
@ -16267,12 +16278,41 @@ function TPasToJSConverter.CreateReferencePath(El: TPasElement;
Result:=CreateReferencePath(AbsolResolved.IdentEl,AContext,Kind,Full,Ref);
end;
function ImplToDecl(El: TPasElement): TPasElement;
var
ProcScope: TPasProcedureScope;
begin
Result:=El;
if El.CustomData is TPasProcedureScope then
begin
// proc: always use the declaration, not the body
ProcScope:=TPasProcedureScope(El.CustomData);
if ProcScope.DeclarationProc<>nil then
Result:=ProcScope.DeclarationProc;
end;
end;
function IsA(SrcType, DstType: TPasType): boolean;
begin
while SrcType<>nil do
begin
if SrcType=DstType then exit(true);
if SrcType.ClassType=TPasClassType then
SrcType:=TPas2JSClassScope(SrcType.CustomData).DirectAncestor
else if (SrcType.ClassType=TPasAliasType)
or (SrcType.ClassType=TPasTypeAliasType) then
SrcType:=TPasAliasType(SrcType).DestType
else
exit(false);
end;
Result:=false;
end;
var
FoundModule: TPasModule;
ParentEl: TPasElement;
Dot: TDotContext;
WithData: TPas2JSWithExprScope;
ProcScope: TPasProcedureScope;
ShortName: String;
SelfContext: TFunctionContext;
ElClass: TClass;
@ -16346,7 +16386,7 @@ begin
end
else if (ElClass=TPasClassType) and TPasClassType(El).IsExternal then
begin
// an external var -> use the literal
// an external class -> use the literal
Result:=TPasClassType(El).ExternalName;
exit;
end
@ -16355,24 +16395,12 @@ begin
// need full path
if El.Parent=nil then
RaiseNotSupported(El,AContext,20170201172141,GetObjName(El));
if (El.CustomData is TPasProcedureScope) then
begin
// proc: always use the declaration, not the body
ProcScope:=TPasProcedureScope(El.CustomData);
if ProcScope.DeclarationProc<>nil then
El:=ProcScope.DeclarationProc;
end;
El:=ImplToDecl(El);
ParentEl:=El.Parent;
while ParentEl<>nil do
begin
if (ParentEl.CustomData is TPasProcedureScope) then
begin
// proc: always use the the declaration, not the body
ProcScope:=TPasProcedureScope(ParentEl.CustomData);
if ProcScope.DeclarationProc<>nil then
ParentEl:=ProcScope.DeclarationProc;
end;
ParentEl:=ImplToDecl(ParentEl);
// check if there is a local var
ShortName:=AContext.GetLocalName(ParentEl);
@ -16410,37 +16438,62 @@ begin
Prepend(Result,ParentEl.Name)
else
begin
// Pascal and JS have similar scoping rules (we are not in a dotscope),
// so 'this' can be used.
// Not in a Pascal dotscope and accessing a class member.
// Possible results: this.v, module.path.path.v, this.path.v
// In nested proc 'this' can have another name, e.g. '$Self'
SelfContext:=AContext.GetSelfContext;
if ShortName<>'' then
Result:=ShortName
else if AContext.GetFunctionContext.ThisPas<>nil then
Result:='this'
else if SelfContext<>nil then
Result:=SelfContext.GetLocalName(SelfContext.ThisPas)
Prepend(Result,ShortName)
else if (El.Parent<>ParentEl) or (El is TPasType) then
Prepend(Result,ParentEl.Name)
else if (SelfContext<>nil)
and IsA(TPasType(SelfContext.ThisPas),TPasType(ParentEl)) then
begin
ShortName:=SelfContext.GetLocalName(SelfContext.ThisPas);
Prepend(Result,ShortName);
end
else
begin
// missing JS var for Self
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateReferencePath missing JS var for Self: El=',El.FullName,':',El.ClassName,' CurParentEl=',ParentEl.FullName,':',ParentEl.ClassName,' AContext:');
AContext.WriteStack;
{$ENDIF}
RaiseNotSupported(El,AContext,20180125004049);
if (SelfContext<>nil) and not IsClassFunction(SelfContext.PasElement) then
end;
if (El.Parent=ParentEl) and (SelfContext<>nil)
and not IsClassFunction(SelfContext.PasElement) then
begin
// inside a method -> Self is a class instance
if El is TPasVariable then
begin
//writeln('TPasToJSConverter.CreateReferencePath class var ',GetObjName(El),' This=',GetObjName(This));
// Note: reading a class var does not need accessing the class
// For example: read v -> this.v
// write v -> this.$class.v
if (ClassVarModifiersType*TPasVariable(El).VarModifiers<>[])
and (AContext.Access=caAssign) then
begin
Append_GetClass(El); // writing a class var
Append_GetClass(El); // writing a class var
end;
end
else if IsClassFunction(El) then
Append_GetClass(El); // accessing a class function
end;
break;
if ShortName<>'' then
break;
end;
end
else if ParentEl.ClassType=TPasEnumType then
Prepend(Result,ParentEl.Name);
begin
if (ShortName<>'') and not Full then
begin
Prepend(Result,ShortName);
break;
end
else
Prepend(Result,ParentEl.Name);
end;
ParentEl:=ParentEl.Parent;
end;
end;

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

@ -441,7 +441,9 @@ type
Procedure TestClassOf_Const;
// nested class
Procedure TestNestedClass_Fail;
Procedure TestNestedClass_Alias;
Procedure TestNestedClass_Record;
Procedure TestNestedClass_Class;
// external class
Procedure TestExternalClass_Var;
@ -10523,12 +10525,12 @@ begin
' Self.SetSize(Self.GetSize() + 8);',
' };',
' Sub();',
' this.Key = this.Key + 12;',
' Self.Key = Self.Key + 12;',
' Self.Key = Self.Key + 13;',
' this.$class.State = this.State + 14;',
' Self.$class.State = Self.State + 14;',
' Self.$class.State = Self.State + 15;',
' $mod.TObject.State = $mod.TObject.State + 16;',
' this.SetSize(this.GetSize() + 17);',
' Self.SetSize(Self.GetSize() + 17);',
' Self.SetSize(Self.GetSize() + 18);',
' };',
'});',
@ -11470,18 +11472,191 @@ begin
'']));
end;
procedure TTestModule.TestNestedClass_Fail;
procedure TTestModule.TestNestedClass_Alias;
begin
Converter.Options:=Converter.Options-[coNoTypeInfo];
StartProgram(false);
Add([
'type',
' TObject = class',
' type TNested = longint;',
' type TNested = type longint;',
' end;',
'begin']);
SetExpectedPasResolverError('not yet implemented: TNested:TPasAliasType [20170608232534] nested types',
nNotYetImplemented);
'type TAlias = type tobject.tnested;',
'var i: tobject.tnested = 3;',
'var j: TAlias = 4;',
'begin',
' if typeinfo(TAlias)=nil then ;',
' if typeinfo(tobject.tnested)=nil then ;',
'']);
ConvertProgram;
CheckSource('TestNestedClass_Alias',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' $mod.$rtti.$inherited("TObject.TNested", rtl.longint, {});',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
'});',
'$mod.$rtti.$inherited("TAlias", $mod.$rtti["TObject.TNested"], {});',
'this.i = 3;',
'this.j = 4;',
'']),
LinesToStr([ // $mod.$main
'if ($mod.$rtti["TAlias"] === null) ;',
'if ($mod.$rtti["TObject.TNested"] === null) ;',
'']));
end;
procedure TTestModule.TestNestedClass_Record;
begin
Converter.Options:=Converter.Options-[coNoTypeInfo];
StartProgram(false);
Add([
'type',
' TObject = class',
' type TPoint = record',
' x,y: byte;',
' end;',
' procedure DoIt(t: TPoint);',
' end;',
'procedure tobject.DoIt(t: TPoint);',
'var p: TPoint;',
'begin',
' t.x:=t.y;',
' p:=t;',
'end;',
'var',
' p: tobject.tpoint = (x:2; y:4);',
' o: TObject;',
'begin',
' p:=p;',
' o.doit(p);',
'']);
ConvertProgram;
CheckSource('TestNestedClass_Record',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' this.TPoint = function (s) {',
' if (s) {',
' this.x = s.x;',
' this.y = s.y;',
' } else {',
' this.x = 0;',
' this.y = 0;',
' };',
' this.$equal = function (b) {',
' return (this.x === b.x) && (this.y === b.y);',
' };',
' };',
' $mod.$rtti.$Record("TObject.TPoint", {}).addFields("x", rtl.byte, "y", rtl.byte);',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.DoIt = function (t) {',
' var p = new this.TPoint();',
' t.x = t.y;',
' p = new this.TPoint(t);',
' };',
'});',
'this.p = new $mod.TObject.TPoint({',
' x: 2,',
' y: 4',
'});',
'this.o = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.p = new $mod.TObject.TPoint($mod.p);',
'$mod.o.DoIt(new $mod.TObject.TPoint($mod.p));',
'']));
end;
procedure TTestModule.TestNestedClass_Class;
begin
Converter.Options:=Converter.Options-[coNoTypeInfo];
StartProgram(false);
Add([
'type',
' TObject = class end;',
' TBird = class',
' type TLeg = class',
' FId: longint;',
' constructor Create;',
' function Create(i: longint): TLeg;',
' end;',
' function DoIt(b: TBird): Tleg;',
' end;',
'constructor tbird.tleg.create;',
'begin',
' FId:=3;',
'end;',
'function tbird.tleg.Create(i: longint): TLeg;',
'begin',
' Create;',
' Result:=TLeg.Create;',
' Result:=TBird.TLeg.Create;',
' Result:=Create(3);',
' FId:=i;',
'end;',
'function tbird.DoIt(b: tbird): tleg;',
'begin',
' Result.Create;',
' Result:=TLeg.Create;',
' Result:=TBird.TLeg.Create;',
' Result:=Result.Create(3);',
'end;',
'var',
' b: Tbird.tleg;',
'begin',
' b.Create;',
' b:=TBird.TLeg.Create;',
' b:=b.Create(3);',
'']);
ConvertProgram;
CheckSource('TestNestedClass_Class',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
'});',
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
' rtl.createClass(this, "TLeg", $mod.TObject, function () {',
' this.$init = function () {',
' $mod.TObject.$init.call(this);',
' this.FId = 0;',
' };',
' this.Create = function () {',
' this.FId = 3;',
' };',
' this.Create$1 = function (i) {',
' var Result = null;',
' this.Create();',
' Result = $mod.TBird.TLeg.$create("Create");',
' Result = $mod.TBird.TLeg.$create("Create");',
' Result = this.Create$1(3);',
' this.FId = i;',
' return Result;',
' };',
' });',
' this.DoIt = function (b) {',
' var Result = null;',
' Result.Create();',
' Result = this.TLeg.$create("Create");',
' Result = $mod.TBird.TLeg.$create("Create");',
' Result = Result.Create$1(3);',
' return Result;',
' };',
'});',
'this.b = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.b.Create();',
'$mod.b = $mod.TBird.TLeg.$create("Create");',
'$mod.b = $mod.b.Create$1(3);',
'']));
end;
procedure TTestModule.TestExternalClass_Var;

3
utils/pas2js/docs/translation.html
View File

@ -1518,7 +1518,7 @@ function(){
<li>Supported: constructor, destructor, private, protected, public,
strict private, strict protected, class vars, class methods, external methods,
virtual, override, abstract, call inherited, assigned(), type cast,
overloads, reintroduce, sealed class</li>
overloads, reintroduce, sealed class, nested types.</li>
<li>Not supported: class constructor/destructor</li>
<li>Property:
<ul>
@ -2863,7 +2863,6 @@ End.
<li>Helpers for types, classes, records</li>
<li>Inline</li>
<li>Library</li>
<li>Nested classes</li>
<li>Objects</li>
<li>Operator overloading</li>
<li>Pointer arithmetic</li>