pastojs: specialize class/record type using pascal name

git-svn-id: trunk@46795 -
2025-04-20 04:59:26 +02:00 · 2020-09-07 17:21:15 +00:00 · 2020-09-07 17:21:15 +00:00 · 2f661371fe
commit 2f661371fe
parent 60c23daa91
3 changed files with 87 additions and 63 deletions
--- a/packages/pastojs/src/fppas2js.pp
+++ b/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;
--- a/packages/pastojs/tests/tcgenerics.pas
+++ b/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);',
    '});',
--- a/utils/pas2js/dist/rtl.js
+++ b/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;