pastojs: nested classes

git-svn-id: trunk@38878 -

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,<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;

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;

utils/pas2js/docs/translation.html

@@ -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>