diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 7039be46f5..38b218234b 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -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,) - 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,) + 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; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index e82640b4b1..708a277219 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -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; diff --git a/utils/pas2js/docs/translation.html b/utils/pas2js/docs/translation.html index c9b453bf83..76585816ab 100644 --- a/utils/pas2js/docs/translation.html +++ b/utils/pas2js/docs/translation.html @@ -1518,7 +1518,7 @@ function(){
  • 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
    • + overloads, reintroduce, sealed class, nested types.
  • Not supported: class constructor/destructor
  • Property:
      @@ -2863,7 +2863,6 @@ End.
    • Helpers for types, classes, records
    • Inline
    • Library
      • -
    • Nested classes
    • Objects
    • Operator overloading
    • Pointer arithmetic