pastojs: specialize class/record type using pascal name

git-svn-id: trunk@46795 -

packages/pastojs/src/fppas2js.pp

@@ -2004,7 +2004,8 @@ type
     Function CreateRecordFunctionAssign(El: TPasRecordType; AContext: TConvertContext;
       Fields: TFPList): TJSElement; virtual;
     Procedure CreateRecordRTTI(El: TPasRecordType; Src: TJSSourceElements;
-      FuncContext: TFunctionContext); virtual;
+      FuncContext: TFunctionContext; MembersSrc: TJSSourceElements;
+      MembersFuncContext: TFunctionContext); virtual;
     Function CreateDelayedInitFunction(PosEl: TPasElement; Src: TJSSourceElements;
       FuncContext: TFunctionContext; out DelaySrc: TJSSourceElements): TFunctionContext; virtual;
     // array
@@ -2022,12 +2023,12 @@ type
     // class
     Procedure AddClassConDestructorFunction(El: TPasClassType; Src: TJSSourceElements;
       ClassContext: TConvertContext; IsTObject: boolean; Ancestor: TPasType;
-      Kind: TMemberFunc);
+      Kind: TMemberFunc); virtual;
     Procedure AddClassRTTI(El: TPasClassType; Src: TJSSourceElements;
-      FuncContext: TFunctionContext);
-    Procedure AddClassConstructors(FuncContext: TFunctionContext; PosEl: TPasElement);
+      FuncContext: TFunctionContext); virtual;
+    Procedure AddClassConstructors(FuncContext: TFunctionContext; PosEl: TPasElement); virtual;
     Procedure AddClassMessageIds(El: TPasClassType; Src: TJSSourceElements;
-      FuncContext: TFunctionContext; pbivn: TPas2JSBuiltInName);
+      FuncContext: TFunctionContext; pbivn: TPas2JSBuiltInName); virtual;
     // misc
     Function CreateCallback(Expr: TPasExpr; ResolvedEl: TPasResolverResult;
       aSafeCall: boolean; AContext: TConvertContext): TJSElement; virtual;
@@ -2066,7 +2067,9 @@ type
       AContext: TConvertContext): TJSElement; virtual;
     Procedure CreateRTTIAnonymous(El: TPasType; AContext: TConvertContext); virtual;
     Function CreateRTTIMembers(El: TPasMembersType; Src: TJSSourceElements;
-      FuncContext: TFunctionContext; RTTIExpr: TJSElement; NeedLocalVar: boolean): boolean; virtual;
+      FuncContext: TFunctionContext; MembersSrc: TJSSourceElements;
+      MembersFuncContext: TFunctionContext; RTTIExpr: TJSElement;
+      NeedLocalVar: boolean): boolean; virtual;
     // create elements for interfaces
     Procedure AddIntfDelegations(ClassEl: TPasElement; Prop: TPasProperty;
       FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral; aContext: TFunctionContext);
@@ -5029,6 +5032,8 @@ begin
   if (C=TPasProcedureType)
       or (C=TPasFunctionType)
       or (C=TPasArrayType)
+      or (C=TPasRecordType)
+      or (C=TPasClassType)
       then
     Result:=inherited CreateSpecializedTypeName(Item)
   else
@@ -6782,6 +6787,10 @@ begin
       Result:=TPas2JSArrayScope(Data).JSName
     else if Data is TPas2JSProcTypeScope then
       Result:=TPas2JSProcTypeScope(Data).JSName
+    else if Data is TPas2JSRecordScope then
+      Result:=TPas2JSRecordScope(Data).JSName
+    else if Data is TPas2JSClassScope then
+      Result:=TPas2JSClassScope(Data).JSName
     else
       Result:='';
     if Result<>'' then exit;
@@ -14839,9 +14848,9 @@ begin
       AncestorPath:=CreateReferencePath(Ancestor,AContext,rpkPathAndName);
     Call.AddArg(CreatePrimitiveDotExpr(AncestorPath,El));
 
+    // for external class: add name of NewInstance function
     if NeedClassExt then
       begin
-      // add the name of the NewInstance function
       if Scope.NewInstanceFunction<>nil then
         Call.AddArg(CreateLiteralString(
           Scope.NewInstanceFunction,Scope.NewInstanceFunction.Name))
@@ -14919,7 +14928,6 @@ begin
           else if C=TPasMethodResolution then
             continue
           else if C=TPasAttributes then
-            // ToDo
             continue
           else
             RaiseNotSupported(P,FuncContext,20161221233338);
@@ -15001,6 +15009,12 @@ begin
 
       end;// end of init function
 
+    // for specialization: add RTTI name
+    if (Scope.JSName<>'') and (Scope.JSName<>El.Name) and HasTypeInfo(El,AContext) then
+      begin
+      Call.AddArg(CreateLiteralString(El,GetTypeInfoName(El,AContext,El)));
+      end;
+
     Result:=Call;
   finally
     FuncContext.Free;
@@ -17281,7 +17295,8 @@ begin
 end;
 
 procedure TPasToJSConverter.CreateRecordRTTI(El: TPasRecordType;
-  Src: TJSSourceElements; FuncContext: TFunctionContext);
+  Src: TJSSourceElements; FuncContext: TFunctionContext;
+  MembersSrc: TJSSourceElements; MembersFuncContext: TFunctionContext);
 var
   ObjLit: TJSObjectLiteral;
   Call: TJSCallExpression;
@@ -17294,11 +17309,14 @@ begin
     if ObjLit=nil then
       RaiseInconsistency(20190105141430,El);
 
-    HasRTTIMembers:=CreateRTTIMembers(El,Src,FuncContext,Call,false);
+    HasRTTIMembers:=CreateRTTIMembers(El,Src,FuncContext,MembersSrc,MembersFuncContext,Call,false);
     if not HasRTTIMembers then
       begin
       // no published members, add "module.$rtti.$Record..."
-      AddToSourceElements(Src,Call);
+      if Src=MembersSrc then
+        AddToSourceElements(Src,Call)
+      else
+        Src.Statements.InsertNode(0).Node:=Call;
       end;
 
     Call:=nil;
@@ -17942,29 +17960,30 @@ var
   ObjLit: TJSObjectLiteral;
   Call: TJSCallExpression;
 begin
-  ClassScope:=El.CustomData as TPas2JSClassScope;
-  if (ClassScope.SpecializedFromItem<>nil)
-      and not (coNoTypeInfo in Options)
-      and FuncContext.Resolver.HasTypeInfo(El) then
-    begin
-    // specialized class -> init RTTI
-    // module.$rtti.$Class("classname");
-    Creator:=GetClassBIName(El,FuncContext);
-    Call:=CreateRTTINewType(El,Creator,true,FuncContext,ObjLit);
-    if ObjLit<>nil then
-      RaiseInconsistency(20200606134834,El);
-    AddHeaderStatement(Call,El,FuncContext);
-    end;
-
   AttrJS:=nil;
-  // this.$rtti
-  RTTIExpr:=CreateMemberExpression(['this',GetBIName(pbivnRTTI)]);
+  RTTIExpr:=nil;
   try
+    ClassScope:=El.CustomData as TPas2JSClassScope;
+    if (ClassScope.SpecializedFromItem<>nil)
+        and not (coNoTypeInfo in Options)
+        and FuncContext.Resolver.HasTypeInfo(El) then
+      begin
+      // specialized class -> init RTTI
+      // add header:  module.$rtti.$Class("classname");
+      Creator:=GetClassBIName(El,FuncContext);
+      Call:=CreateRTTINewType(El,Creator,true,FuncContext,ObjLit);
+      if ObjLit<>nil then
+        RaiseInconsistency(20200606134834,El);
+      AddHeaderStatement(Call,El,FuncContext);
+      end;
+
+    // this.$rtti
+    RTTIExpr:=CreateMemberExpression(['this',GetBIName(pbivnRTTI)]);
     Attr:=FuncContext.Resolver.GetAttributeCallsEl(El);
     AttrJS:=CreateRTTIAttributes(Attr,El,FuncContext);
-    NeedLocalVar:=AttrJS<>nil;
+    NeedLocalVar:=(AttrJS<>nil);
 
-    HasRTTIMembers:=CreateRTTIMembers(El,Src,FuncContext,RTTIExpr,NeedLocalVar);
+    HasRTTIMembers:=CreateRTTIMembers(El,Src,FuncContext,Src,FuncContext,RTTIExpr,NeedLocalVar);
     if HasRTTIMembers then
       RTTIExpr:=nil;
 
@@ -19368,8 +19387,9 @@ begin
 end;
 
 function TPasToJSConverter.CreateRTTIMembers(El: TPasMembersType;
-  Src: TJSSourceElements; FuncContext: TFunctionContext; RTTIExpr: TJSElement;
-  NeedLocalVar: boolean): boolean;
+  Src: TJSSourceElements; FuncContext: TFunctionContext;
+  MembersSrc: TJSSourceElements; MembersFuncContext: TFunctionContext;
+  RTTIExpr: TJSElement; NeedLocalVar: boolean): boolean;
 type
   TMemberType = (
     mtClass,
@@ -19385,7 +19405,10 @@ type
     // add "var $r = module.$rtti.$Record..."
     Result:=true;
     VarSt:=CreateVarStatement(GetBIName(pbivnRTTILocal),RTTIExpr,El);
-    AddToSourceElements(Src,VarSt);
+    if Src=MembersSrc then
+      AddToSourceElements(Src,VarSt)
+    else
+      Src.Statements.InsertNode(0).Node:=VarSt;
   end;
 
 var
@@ -19432,11 +19455,11 @@ begin
 
     NewEl:=nil;
     if C=TPasVariable then
-      NewEl:=CreateRTTIMemberField(Members,i,FuncContext)
+      NewEl:=CreateRTTIMemberField(Members,i,MembersFuncContext)
     else if C.InheritsFrom(TPasProcedure) then
-      NewEl:=CreateRTTIMemberMethod(Members,i,FuncContext)
+      NewEl:=CreateRTTIMemberMethod(Members,i,MembersFuncContext)
     else if C=TPasProperty then
-      NewEl:=CreateRTTIMemberProperty(Members,i,FuncContext)
+      NewEl:=CreateRTTIMemberProperty(Members,i,MembersFuncContext)
     else if C.InheritsFrom(TPasType)
         or (C=TPasAttributes) then
     else
@@ -19446,7 +19469,7 @@ begin
     // add RTTI element
     if not Result then
       CreateLocalvar;
-    AddToSourceElements(Src,NewEl);
+    AddToSourceElements(MembersSrc,NewEl);
     end;
 end;
 
@@ -25272,9 +25295,9 @@ begin
     if (aResolver<>nil) and HasTypeInfo(El,FuncContext) then
       begin
       if SpecializeDelay then
-        CreateRecordRTTI(El,DelaySrc,DelayFuncContext)
+        CreateRecordRTTI(El,Src,FuncContext,DelaySrc,DelayFuncContext)
       else
-        CreateRecordRTTI(El,Src,FuncContext);
+        CreateRecordRTTI(El,Src,FuncContext,Src,FuncContext);
       end;
 
     ok:=true;

packages/pastojs/tests/tcgenerics.pas

@@ -309,9 +309,9 @@ begin
     LinesToStr([ // statements
     'var $impl = $mod.$impl;',
     'rtl.recNewT($mod, "TAnt$G1", function () {',
+    '  var $r = $mod.$rtti.$Record("TAnt<Test1.TBird>", {});',
     '  this.$initSpec = function () {',
     '    this.x = $impl.TBird.$new();',
-    '    var $r = $mod.$rtti.$Record("TAnt$G1", {});',
     '    $r.addField("x", $mod.$rtti["TBird"]);',
     '  };',
     '  this.$eq = function (b) {',
@@ -323,7 +323,7 @@ begin
     '}, true);',
     '']),
     LinesToStr([ // $mod.$init
-    '$impl.p = $mod.$rtti["TAnt$G1"];',
+    '$impl.p = $mod.$rtti["TAnt<Test1.TBird>"];',
     '']),
     LinesToStr([ // statements
     'rtl.recNewT($impl, "TBird", function () {',
@@ -598,7 +598,7 @@ begin
   ConvertProgram;
   CheckSource('TestGen_Class_TypeInfo',
     LinesToStr([ // statements
-    '$mod.$rtti.$Class("TBird$G1");',
+    '$mod.$rtti.$Class("TBird<System.Word>");',
     'rtl.createClass($mod, "TObject", null, function () {',
     '  this.$init = function () {',
     '  };',
@@ -612,12 +612,12 @@ begin
     '  };',
     '  var $r = this.$rtti;',
     '  $r.addField("m", rtl.word);',
-    '});',
+    '}, "TBird<System.Word>");',
     'this.b = null;',
     'this.p = null;',
     '']),
     LinesToStr([ // $mod.$main
-    '$mod.p = $mod.$rtti["TBird$G1"];',
+    '$mod.p = $mod.$rtti["TBird<System.Word>"];',
     '$mod.p = $mod.b.$rtti;',
     '']));
 end;
@@ -870,7 +870,7 @@ begin
     LinesToStr([ // $mod.$main
     '$mod.w = $mod.c;',
     '']));
-  CheckHint(mtWarning,nClassTypesAreNotRelatedXY,'Class types "TBird$G2" and "TBird$G1" are not related');
+  CheckHint(mtWarning,nClassTypesAreNotRelatedXY,'Class types "TBird<System.Char>" and "TBird<System.Word>" are not related');
   CheckResolverUnexpectedHints();
 end;
 
@@ -1071,8 +1071,8 @@ begin
   ConvertProgram;
   CheckSource('TestGen_ClassForward_CircleRTTI',
     LinesToStr([ // statements
-    '$mod.$rtti.$Class("TAnt$G2");',
-    '$mod.$rtti.$Class("TFish$G2");',
+    '$mod.$rtti.$Class("TAnt<System.Word>");',
+    '$mod.$rtti.$Class("TFish<System.Word>");',
     'rtl.createClass($mod, "TObject", null, function () {',
     '  this.$init = function () {',
     '  };',
@@ -1091,8 +1091,8 @@ begin
     '    $mod.TPersistent.$final.call(this);',
     '  };',
     '  var $r = this.$rtti;',
-    '  $r.addField("f", $mod.$rtti["TFish$G2"]);',
-    '});',
+    '  $r.addField("f", $mod.$rtti["TFish<System.Word>"]);',
+    '}, "TAnt<System.Word>");',
     'rtl.createClass($mod, "TFish$G2", $mod.TPersistent, function () {',
     '  this.$init = function () {',
     '    $mod.TPersistent.$init.call(this);',
@@ -1103,14 +1103,14 @@ begin
     '    $mod.TPersistent.$final.call(this);',
     '  };',
     '  var $r = this.$rtti;',
-    '  $r.addField("a", $mod.$rtti["TAnt$G2"]);',
-    '});',
+    '  $r.addField("a", $mod.$rtti["TAnt<System.Word>"]);',
+    '}, "TFish<System.Word>");',
     'this.WordFish = null;',
     'this.p = null;',
     '']),
     LinesToStr([ // $mod.$main
-    '$mod.p = $mod.$rtti["TAnt$G2"];',
-    '$mod.p = $mod.$rtti["TFish$G2"];',
+    '$mod.p = $mod.$rtti["TAnt<System.Word>"];',
+    '$mod.p = $mod.$rtti["TFish<System.Word>"];',
     '']));
 end;
 
@@ -1314,11 +1314,11 @@ begin
   ConvertProgram;
   CheckSource('TestGen_ExtClass_RTTI',
     LinesToStr([ // statements
-    '$mod.$rtti.$ExtClass("TGJSSET$G1", {',
+    '$mod.$rtti.$ExtClass("TGJSSET<System.JSValue>", {',
     '  jsclass: "SET"',
     '});',
     '$mod.$rtti.$RefToProcVar("TJSSetEventProc", {',
-    '  procsig: rtl.newTIProcSig([["value", rtl.jsvalue], ["key", rtl.nativeint], ["set_", $mod.$rtti["TGJSSET$G1"]]])',
+    '  procsig: rtl.newTIProcSig([["value", rtl.jsvalue], ["key", rtl.nativeint], ["set_", $mod.$rtti["TGJSSET<System.JSValue>"]]])',
     '});',
     'this.p = null;',
     '']),
@@ -1360,7 +1360,7 @@ begin
     'rtl.module("UnitA", ["system"], function () {',
     '  var $mod = this;',
     '  var $impl = $mod.$impl;',
-    '  $mod.$rtti.$ExtClass("TAnt$G1", {',
+    '  $mod.$rtti.$ExtClass("TAnt<UnitA.TBird>", {',
     '    jsclass: "SET"',
     '  });',
     '  $mod.$init = function () {',
@@ -1432,7 +1432,7 @@ begin
     '  this.$final = function () {',
     '  };',
     '});',
-    'rtl.createInterface($mod, "IBird$G2", "{7D9907A1-5178-37B5-9D32-7BC020005905}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
+    'rtl.createInterface($mod, "IBird$G2", "{33AB51C6-6240-3BDF-B4B0-D48A593EAB0A}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
     'rtl.createClass($mod, "TBird$G1", $mod.TObject, function () {',
     '  rtl.addIntf(this, $mod.IBird$G2);',
     '});',

utils/pas2js/dist/rtl.js

@@ -286,15 +286,16 @@ var rtl = {
     return parent;
   },
 
-  initClass: function(c,parent,name,initfn){
+  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 = name;
+    c.$classname = rttiname;
     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(c.$name,{ "class": c });
+    var t = c.$module.$rtti.$Class(rttiname,{ "class": c });
     c.$rtti = t;
     if (rtl.isObject(c.$ancestor)) t.ancestor = c.$ancestor.$rtti;
     if (!t.ancestor) t.ancestor = null;
@@ -302,7 +303,7 @@ var rtl = {
     initfn.call(c);
   },
 
-  createClass: function(parent,name,ancestor,initfn){
+  createClass: function(parent,name,ancestor,initfn,rttiname){
     // create a normal class,
     // ancestor must be null or a normal class,
     // the root ancestor can be an external class
@@ -340,10 +341,10 @@ var rtl = {
         this.$final();
       };
     };
-    rtl.initClass(c,parent,name,initfn);
+    rtl.initClass(c,parent,name,initfn,rttiname);
   },
 
-  createClassExt: function(parent,name,ancestor,newinstancefnname,initfn){
+  createClassExt: function(parent,name,ancestor,newinstancefnname,initfn,rttiname){
     // Create a class using an external ancestor.
     // If newinstancefnname is given, use that function to create the new object.
     // If exist call BeforeDestruction and AfterConstruction.
@@ -391,7 +392,7 @@ var rtl = {
       if (this[fnname]) this[fnname]();
       if (this.$final) this.$final();
     };
-    rtl.initClass(c,parent,name,initfn);
+    rtl.initClass(c,parent,name,initfn,rttiname);
     if (isFunc){
       function f(){}
       f.prototype = c;