pastojs: classname=typeinfoname

git-svn-id: trunk@46986 -

packages/pastojs/src/fppas2js.pp

@@ -15177,7 +15177,8 @@ begin
       end;// end of init function
 
     // for specialization: add RTTI name
-    if (Scope.JSName<>'') and (Scope.JSName<>El.Name) and HasTypeInfo(El,AContext) then
+    if ((Scope.JSName<>'') and (Scope.JSName<>El.Name))
+        or (El.Parent is TPasMembersType) then
       begin
       Call.AddArg(CreateLiteralString(El,GetTypeInfoName(El,AContext,El)));
       end;

packages/pastojs/tests/tcgenerics.pas

@@ -27,7 +27,7 @@ type
     Procedure TestGen_ClassEmpty;
     Procedure TestGen_Class_EmptyMethod;
     Procedure TestGen_Class_TList;
-    Procedure TestGen_Class_TCustomList;
+    Procedure TestGen_Class_TCustomList; // ToDo: with Self do Result:=Method()
     Procedure TestGen_ClassAncestor;
     Procedure TestGen_Class_TypeInfo;
     Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
@@ -37,12 +37,13 @@ type
     Procedure TestGen_Class_ClassConstructor;
     Procedure TestGen_Class_TypeCastSpecializesWarn;
     Procedure TestGen_Class_TypeCastSpecializesJSValueNoWarn;
-    procedure TestGen_Class_VarArgsOfType;
     procedure TestGen_Class_OverloadsInUnit;
     procedure TestGen_ClassForward_CircleRTTI;
+    procedure TestGen_Class_Nested_RTTI;
     Procedure TestGen_Class_ClassVarRecord_UnitImpl;
 
     // generic external class
+    procedure TestGen_ExtClass_VarArgsOfType;
     procedure TestGen_ExtClass_Array;
     procedure TestGen_ExtClass_GenJSValueAssign;
     procedure TestGen_ExtClass_AliasMemberType;
@@ -365,7 +366,7 @@ begin
     '  };',
     '});',
     'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
-    '});',
+    '}, "TBird<System.Word>");',
     'this.a = null;',
     'this.b = null;',
     '']),
@@ -403,7 +404,7 @@ begin
     '    var Result = 0;',
     '    return Result;',
     '  };',
-    '});',
+    '}, "TBird<System.Word>");',
     'this.a = null;',
     '']),
     LinesToStr([ // $mod.$main
@@ -479,7 +480,7 @@ begin
     '    this.FItems.splice(2, 0, w);',
     '    this.FItems.splice(2, 3);',
     '  };',
-    '});',
+    '}, "TList<System.Word>");',
     'this.l = null;',
     'this.w = 0;',
     '']),
@@ -511,7 +512,7 @@ begin
   'function TList<T>.Add: word;',
   'begin',
   '  Result:=PrepareAddingItem;',
-  //'  Result:=Self.PrepareAddingItem;',
+  '  Result:=Self.PrepareAddingItem;',
   //'  with Self do Result:=PrepareAddingItem;',
   'end;',
   'var l: TWordList;',
@@ -531,14 +532,15 @@ begin
     '    var Result = 0;',
     '    return Result;',
     '  };',
-    '});',
+    '}, "TCustomList<System.Word>");',
     'rtl.createClass(this, "TList$G1", this.TCustomList$G2, function () {',
     '  this.Add = function () {',
     '    var Result = 0;',
     '    Result = this.PrepareAddingItem();',
+    '    Result = this.PrepareAddingItem();',
     '    return Result;',
     '  };',
-    '});',
+    '}, "TList<System.Word>");',
     'this.l = null;',
     '']),
     LinesToStr([ // $mod.$main
@@ -568,9 +570,9 @@ begin
     '  };',
     '});',
     'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
-    '});',
+    '}, "TBird<System.Word>");',
     'rtl.createClass(this, "TEagle$G1", this.TBird$G2, function () {',
-    '});',
+    '}, "TEagle<System.Word>");',
     'this.a = null;',
     '']),
     LinesToStr([ // $mod.$main
@@ -684,7 +686,7 @@ begin
     '});',
     'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
     '  this.fSize = 0;',
-    '});',
+    '}, "TBird<System.Word>");',
     '']),
     LinesToStr([ // $mod.$main
     '$mod.TBird$G1.fSize = 3 + $mod.TBird$G1.fSize;',
@@ -750,7 +752,7 @@ begin
     '    this.Run();',
     '    $mod.TPoint$G1.Run();',
     '  };',
-    '});',
+    '}, "TPoint<System.Word>");',
     'this.p = null;',
     '']),
     LinesToStr([ // $mod.$main
@@ -800,13 +802,13 @@ begin
     '  this.x = 0;',
     '  this.Fly = function () {',
     '  };',
-    '});',
+    '}, "TPoint<System.Word>");',
     'this.r = null;',
     'rtl.createClass(this, "TPoint$G2", this.TObject, function () {',
     '  this.x = 0;',
     '  this.Fly = function () {',
     '  };',
-    '});',
+    '}, "TPoint<System.SmallInt>");',
     'this.s = null;',
     '']),
     LinesToStr([ // $mod.$main
@@ -858,13 +860,13 @@ begin
     '    $mod.TObject.$init.call(this);',
     '    this.F = 0;',
     '  };',
-    '});',
+    '}, "TBird<System.Word>");',
     'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
     '  this.$init = function () {',
     '    $mod.TObject.$init.call(this);',
     '    this.F = "";',
     '  };',
-    '});',
+    '}, "TBird<System.Char>");',
     'this.w = null;',
     'this.c = null;',
     '']),
@@ -906,13 +908,13 @@ begin
     '    $mod.TObject.$init.call(this);',
     '    this.F = 0;',
     '  };',
-    '});',
+    '}, "TBird<System.Word>");',
     'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
     '  this.$init = function () {',
     '    $mod.TObject.$init.call(this);',
     '    this.F = undefined;',
     '  };',
-    '});',
+    '}, "TBird<System.JSValue>");',
     'this.w = null;',
     'this.a = null;',
     '']),
@@ -923,45 +925,6 @@ begin
   CheckResolverUnexpectedHints();
 end;
 
-procedure TTestGenerics.TestGen_Class_VarArgsOfType;
-begin
-  StartProgram(false);
-  Add([
-  '{$mode objfpc}',
-  '{$modeswitch externalclass}',
-  'type',
-  '  TJSObject = class external name ''Object''',
-  '  end;',
-  '  generic TGJSSet<T> = class external name ''Set''',
-  '    constructor new(aElement1: T); varargs of T; overload;',
-  '    function bind(thisArg: TJSObject): T; varargs of T;',
-  '  end;',
-  '  TJSWordSet = specialize TGJSSet<word>;',
-  'var',
-  '  s: TJSWordSet;',
-  '  w: word;',
-  'begin',
-  '  s:=TJSWordSet.new(3);',
-  '  s:=TJSWordSet.new(3,5);',
-  '  w:=s.bind(nil);',
-  '  w:=s.bind(nil,6);',
-  '  w:=s.bind(nil,7,8);',
-  '']);
-  ConvertProgram;
-  CheckSource('TestGen_Class_VarArgsOfType',
-    LinesToStr([ // statements
-    'this.s = null;',
-    'this.w = 0;',
-    '']),
-    LinesToStr([ // $mod.$main
-    '$mod.s = new Set(3);',
-    '$mod.s = new Set(3, 5);',
-    '$mod.w = $mod.s.bind(null);',
-    '$mod.w = $mod.s.bind(null, 6);',
-    '$mod.w = $mod.s.bind(null, 7, 8);',
-    '']));
-end;
-
 procedure TTestGenerics.TestGen_Class_OverloadsInUnit;
 begin
   StartProgram(true,[supTObject]);
@@ -1013,7 +976,7 @@ begin
     '    this.Create$2 = function (b) {',
     '      return this;',
     '    };',
-    '  });',
+    '  }, "TBird<System.Word>");',
     '  rtl.createClass(this, "TBird$G2", pas.system.TObject, function () {',
     '    this.c = 13;',
     '    var c$1 = 14;',
@@ -1024,7 +987,7 @@ begin
     '    this.Create$2 = function (b) {',
     '      return this;',
     '    };',
-    '  });',
+    '  }, "TBird<System.Double>");',
     '});',
     '']));
   CheckSource('TestGen_Class_OverloadsInUnit',
@@ -1115,6 +1078,57 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_Class_Nested_RTTI;
+begin
+  WithTypeInfo:=true;
+  StartProgram(true,[supTObject]);
+  AddModuleWithIntfImplSrc('UnitA.pas',
+  LinesToStr([
+  'type',
+  '  generic TAnt<T> = class',
+  '  type',
+  '    TLeg = class',
+  '    published',
+  '      Size: T;',
+  '    end;',
+  '  end;',
+  '  TBoolAnt = specialize TAnt<boolean>;',
+  '']),
+  LinesToStr([
+  '']));
+  Add([
+  'uses UnitA;',
+  'var',
+  '  BoolLeg: TBoolAnt.TLeg;',
+  'begin',
+  '  if typeinfo(TBoolAnt.TLeg)=nil then ;',
+  '']);
+  ConvertProgram;
+  CheckUnit('UnitA.pas',
+    LinesToStr([ // statements
+    'rtl.module("UnitA", ["system"], function () {',
+    '  var $mod = this;',
+    '  $mod.$rtti.$Class("TAnt<System.Boolean>");',
+    '  rtl.createClass(this, "TAnt$G1", pas.system.TObject, function () {',
+    '    rtl.createClass(this, "TLeg", pas.system.TObject, function () {',
+    '      this.$init = function () {',
+    '        pas.system.TObject.$init.call(this);',
+    '        this.Size = false;',
+    '      };',
+    '      var $r = this.$rtti;',
+    '      $r.addField("Size", rtl.boolean);',
+    '    }, "TAnt<System.Boolean>.TLeg");',
+    '  }, "TAnt<System.Boolean>");',
+    '});']));
+  CheckSource('TestGen_Class_Nested_RTTI',
+    LinesToStr([ // statements
+    'this.BoolLeg = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    'if (pas.UnitA.$rtti["TAnt<System.Boolean>.TLeg"] === null) ;',
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_Class_ClassVarRecord_UnitImpl;
 begin
   StartProgram(true,[supTObject]);
@@ -1151,7 +1165,7 @@ begin
     '      this.x = $impl.TBird.$new();',
     '      this.a = rtl.arraySetLength(null, $impl.TBird, 2);',
     '    };',
-    '  });',
+    '  }, "TAnt<UnitA.TBird>");',
     '  $mod.$implcode = function () {',
     '    rtl.recNewT($impl, "TBird", function () {',
     '      this.b = 0;',
@@ -1168,7 +1182,8 @@ begin
     '  $mod.$init = function () {',
     '    $impl.f.x.b = $impl.f.x.b + 10;',
     '  };',
-    '}, []);']));
+    '}, []);',
+    '']));
   CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
     LinesToStr([ // statements
     'pas.UnitA.TAnt$G1.$initSpec();',
@@ -1177,6 +1192,45 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_ExtClass_VarArgsOfType;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  '{$modeswitch externalclass}',
+  'type',
+  '  TJSObject = class external name ''Object''',
+  '  end;',
+  '  generic TGJSSet<T> = class external name ''Set''',
+  '    constructor new(aElement1: T); varargs of T; overload;',
+  '    function bind(thisArg: TJSObject): T; varargs of T;',
+  '  end;',
+  '  TJSWordSet = specialize TGJSSet<word>;',
+  'var',
+  '  s: TJSWordSet;',
+  '  w: word;',
+  'begin',
+  '  s:=TJSWordSet.new(3);',
+  '  s:=TJSWordSet.new(3,5);',
+  '  w:=s.bind(nil);',
+  '  w:=s.bind(nil,6);',
+  '  w:=s.bind(nil,7,8);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_ExtClass_VarArgsOfType',
+    LinesToStr([ // statements
+    'this.s = null;',
+    'this.w = 0;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.s = new Set(3);',
+    '$mod.s = new Set(3, 5);',
+    '$mod.w = $mod.s.bind(null);',
+    '$mod.w = $mod.s.bind(null, 6);',
+    '$mod.w = $mod.s.bind(null, 7, 8);',
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_ExtClass_Array;
 begin
   StartProgram(false);
@@ -1431,10 +1485,17 @@ begin
     '  this.$final = function () {',
     '  };',
     '});',
-    'rtl.createInterface(this, "IBird$G2", "{33AB51C6-6240-3BDF-B4B0-D48A593EAB0A}", ["GetSize", "SetSize", "DoIt"], this.IUnknown);',
+    'rtl.createInterface(',
+    '  this,',
+    '  "IBird$G2",',
+    '  "{33AB51C6-6240-3BDF-B4B0-D48A593EAB0A}",',
+    '  ["GetSize", "SetSize", "DoIt"],',
+    '  this.IUnknown,',
+    '  "IBird<System.Word>"',
+    ');',
     'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
     '  rtl.addIntf(this, $mod.IBird$G2);',
-    '});',
+    '}, "TBird<System.Word>");',
     'this.BirdIntf = null;',
     '']),
     LinesToStr([ // $mod.$main
@@ -1463,7 +1524,14 @@ begin
   ConvertProgram;
   CheckSource('TestGen_ClassInterface_InterfacedObject',
     LinesToStr([ // statements
-    'rtl.createInterface(this, "IComparer$G2", "{505778ED-F783-4456-9691-32F419CC5E18}", ["Compare"], pas.system.IUnknown);',
+    'rtl.createInterface(',
+    '  this,',
+    '  "IComparer$G2",',
+    '  "{505778ED-F783-4456-9691-32F419CC5E18}",',
+    '  ["Compare"],',
+    '  pas.system.IUnknown,',
+    '  "IComparer<System.Longint>"',
+    ');',
     'this.aComparer = null;',
     'rtl.createClass(this, "TComparer$G1", pas.system.TInterfacedObject, function () {',
     '  this.Compare = function (Left, Right) {',
@@ -1472,7 +1540,7 @@ begin
     '  };',
     '  rtl.addIntf(this, $mod.IComparer$G2);',
     '  rtl.addIntf(this, pas.system.IUnknown);',
-    '});',
+    '}, "TComparer<System.Longint>");',
     '']),
     LinesToStr([ // $mod.$main
     'rtl.setIntfP($mod, "aComparer", rtl.queryIntfT($mod.TComparer$G1.$create("Create"), $mod.IComparer$G2), true);',
@@ -1549,7 +1617,7 @@ begin
     '  };',
     '});',
     'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
-    '});',
+    '}, "TBird<System.Word>");',
     'this.b = null;',
     '']),
     LinesToStr([ // $mod.$main
@@ -1592,13 +1660,13 @@ begin
     '    this.Fly = function () {',
     '      $impl.DoIt();',
     '    };',
-    '  });',
+    '  }, "TBird<System.Boolean>");',
     '  this.b = null;',
     '  rtl.createClass(this, "TBird$G2", pas.system.TObject, function () {',
     '    this.Fly = function () {',
     '      $impl.DoIt();',
     '    };',
-    '  });',
+    '  }, "TBird<System.Word>");',
     '  $mod.$implcode = function () {',
     '    $impl.DoIt = function () {',
     '      var b = null;',
@@ -1646,7 +1714,7 @@ begin
     '    var i = 0;',
     '    i = this.m;',
     '  };',
-    '});',
+    '}, "TBird<System.Word>");',
     'this.b = null;',
     '']),
     LinesToStr([ // $mod.$main
@@ -1694,7 +1762,7 @@ begin
     '    $mod.o.Field = 3;',
     '    if (4 === $mod.o.Field) ;',
     '  };',
-    '});',
+    '}, "TBird<System.Word>");',
     'this.b = null;',
     '']),
     LinesToStr([ // $mod.$main

packages/pastojs/tests/tcmodules.pas

@@ -11964,7 +11964,7 @@ begin
     '      this.Glob();',
     '      this.Glob();',
     '    };',
-    '  });',
+    '  }, "TPoint.TBird");',
     '  this.$eq = function (b) {',
     '    return true;',
     '  };',
@@ -16395,7 +16395,7 @@ begin
     '      this.FId = i;',
     '      return Result;',
     '    };',
-    '  });',
+    '  }, "TBird.TLeg");',
     '  this.DoIt = function (b) {',
     '    var Result = null;',
     '    Result.Create();',

packages/pastojs/tests/tcoptimizations.pas

@@ -634,7 +634,7 @@ begin
     '  $lt = this;',
     '  rtl.createClass(this, "TLeg", $lt4, function () {',
     '    $lt1 = this;',
-    '  });',
+    '  }, "TAnt.TLeg");',
     '  this.$init = function () {',
     '    $lt4.$init.call(this);',
     '    this.Bird = null;',

packages/pastojs/tests/tcsrcmap.pas

@@ -16,7 +16,7 @@
  Examples:
     ./testpas2js --suite=TTestSrcMap.TestEmptyProgram
 }
-unit tcsrcmap;
+unit TCSrcMap;
 
 {$mode objfpc}{$H+}
 

packages/pastojs/tests/testpas2js.lpi

@@ -64,6 +64,7 @@
       <Unit5>
         <Filename Value="tcsrcmap.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="TCSrcMap"/>
       </Unit5>
       <Unit6>
         <Filename Value="../src/fppjssrcmap.pp"/>

packages/pastojs/tests/testpas2js.pp

@@ -20,8 +20,8 @@ uses
   {$IFDEF EnableMemCheck}
   MemCheck,
   {$ENDIF}
-  Classes, consoletestrunner, tcconverter, TCModules, tcoptimizations, tcsrcmap,
-  tcfiler, tcunitsearch, tcprecompile, TCGenerics;
+  Classes, consoletestrunner, tcconverter, TCModules, TCSrcMap,
+  TCFiler, TCUnitSearch, TCOptimizations, TCGenerics, TCPrecompile;
 
 type
 

utils/pas2js/dist/rtl.js

@@ -286,15 +286,14 @@ var rtl = {
   },
 
   initClass: function(c,parent,name,initfn,rttiname){
-    if (!rttiname) rttiname = name;
     parent[name] = c;
     c.$class = c; // Note: o.$class === Object.getPrototypeOf(o)
-    c.$classname = rttiname;
+    c.$classname = rttiname?rttiname:name;
     parent = rtl.initStruct(c,parent,name);
     c.$fullname = parent.$name+'.'+name;
     // rtti
     if (rtl.debug_rtti) rtl.debug('initClass '+c.$fullname);
-    var t = c.$module.$rtti.$Class(rttiname,{ "class": c });
+    var t = c.$module.$rtti.$Class(c.$classname,{ "class": c });
     c.$rtti = t;
     if (rtl.isObject(c.$ancestor)) t.ancestor = c.$ancestor.$rtti;
     if (!t.ancestor) t.ancestor = null;
@@ -402,7 +401,7 @@ var rtl = {
     }
   },
 
-  createHelper: function(parent,name,ancestor,initfn){
+  createHelper: function(parent,name,ancestor,initfn,rttiname){
     // create a helper,
     // ancestor must be null or a helper,
     var c = null;
@@ -415,11 +414,11 @@ var rtl = {
     };
     parent[name] = c;
     c.$class = c; // Note: o.$class === Object.getPrototypeOf(o)
-    c.$classname = name;
+    c.$classname = rttiname?rttiname:name;
     parent = rtl.initStruct(c,parent,name);
     c.$fullname = parent.$name+'.'+name;
     // rtti
-    var t = c.$module.$rtti.$Helper(c.$name,{ "helper": c });
+    var t = c.$module.$rtti.$Helper(c.$classname,{ "helper": c });
     c.$rtti = t;
     if (rtl.isObject(ancestor)) t.ancestor = ancestor.$rtti;
     if (!t.ancestor) t.ancestor = null;