pastojs: override scope class array and proctype

git-svn-id: trunk@46768 -

packages/pastojs/src/fppas2js.pp

@@ -1166,6 +1166,7 @@ type
 
   TPas2JSClassScope = class(TPasClassScope)
   public
+    LongName: string;
     NewInstanceFunction: TPasClassFunction;
     GUID: string;
     ElevatedLocals: TPas2jsElevatedLocals;
@@ -1183,6 +1184,7 @@ type
 
   TPas2JSRecordScope = class(TPasRecordScope)
   public
+    LongName: string;
     MemberOverloadsRenamed: boolean;
   end;
 
@@ -1191,6 +1193,7 @@ type
   TPas2JSProcedureScope = class(TPasProcedureScope)
   public
     OverloadName: string;
+    LongName: string;
     ResultVarName: string; // valid in implementation ProcScope, empty means use ResolverResultVar
     BodyOverloadsRenamed: boolean;
     BodyJS: string; // Option coStoreProcJS: stored in ImplScope
@@ -1200,6 +1203,20 @@ type
     destructor Destroy; override;
   end;
 
+  { TPas2JSArrayScope }
+
+  TPas2JSArrayScope = Class(TPasArrayScope)
+  public
+    LongName: string;
+  end;
+
+  { TPas2JSProcTypeScope }
+
+  TPas2JSProcTypeScope = Class(TPasProcTypeScope)
+  public
+    LongName: string;
+  end;
+
   { TPas2JSWithExprScope }
 
   TPas2JSWithExprScope = class(TPasWithExprScope)
@@ -1495,9 +1512,12 @@ type
     function GenerateGUID(El: TPasClassType): string; virtual;
   protected
     // generic/specialize
+    procedure SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem);
+      override;
     procedure SpecializeGenericImpl(SpecializedItem: TPRSpecializedItem);
       override;
     function SpecializeNeedsDelay(SpecializedItem: TPRSpecializedItem): TPasElement; virtual;
+    function CreateLongName(SpecializedItem: TPRSpecializedItem): string; virtual;
   protected
     const
       cJSValueConversion = 2*cTypeConversion;
@@ -4955,6 +4975,49 @@ begin
   Result:=Result+'}';
 end;
 
+procedure TPas2JSResolver.SpecializeGenericIntf(
+  SpecializedItem: TPRSpecializedItem);
+{$IFDEF EnableLongNames}
+var
+  El: TPasElement;
+  C: TClass;
+  RecScope: TPas2JSRecordScope;
+  ClassScope: TPas2JSClassScope;
+  ArrayScope: TPas2JSArrayScope;
+  ProcTypeScope: TPas2JSProcTypeScope;
+  LongName: String;
+{$ENDIF}
+begin
+  {$IFDEF EnableLongNames}
+  El:=SpecializedItem.SpecializedEl;
+  C:=El.ClassType;
+  LongName:=CreateLongName(SpecializedItem);
+  if C=TPasRecordType then
+    begin
+    RecScope:=TPas2JSRecordScope(El.CustomData);
+    RecScope.LongName:=LongName;
+    end
+  else if C=TPasClassType then
+    begin
+    ClassScope:=TPas2JSClassScope(El.CustomData);
+    ClassScope.LongName:=LongName;
+    end
+  else if C=TPasArrayType then
+    begin
+    ArrayScope:=TPas2JSArrayScope(El.CustomData);
+    ArrayScope.LongName:=LongName;
+    end
+  else if (C=TPasProcedureType) or (C=TPasFunctionType) then
+    begin
+    ProcTypeScope:=TPas2JSProcTypeScope(El.CustomData);
+    ProcTypeScope.LongName:=LongName;
+    end
+  else
+    RaiseNotYetImplemented(20200904132908,El);
+  {$ENDIF}
+  inherited SpecializeGenericIntf(SpecializedItem);
+end;
+
 procedure TPas2JSResolver.SpecializeGenericImpl(
   SpecializedItem: TPRSpecializedItem);
 var
@@ -5037,6 +5100,24 @@ begin
     end;
 end;
 
+function TPas2JSResolver.CreateLongName(SpecializedItem: TPRSpecializedItem
+  ): string;
+var
+  GenEl: TPasElement;
+  i: Integer;
+  Param: TPasType;
+begin
+  GenEl:=SpecializedItem.GenericEl;
+  Result:=GenEl.Name+'<';
+  for i:=0 to length(SpecializedItem.Params)-1 do
+    begin
+    Param:=ResolveAliasType(SpecializedItem.Params[i],false);
+    // ToDo  move to resolver
+    if Param=nil then ;
+    end;
+  Result:=Result+'>';
+end;
+
 function TPas2JSResolver.AddJSBaseType(const aName: string; Typ: TPas2jsBaseType
   ): TResElDataPas2JSBaseType;
 var
@@ -5827,6 +5908,8 @@ begin
   ScopeClass_Module:=TPas2JSModuleScope;
   ScopeClass_Procedure:=TPas2JSProcedureScope;
   ScopeClass_Record:=TPas2JSRecordScope;
+  ScopeClass_Array:=TPas2JSArrayScope;
+  ScopeClass_ProcType:=TPas2JSProcTypeScope;
   ScopeClass_Section:=TPas2JSSectionScope;
   ScopeClass_WithExpr:=TPas2JSWithExprScope;
   for bt in [pbtJSValue] do
@@ -15400,7 +15483,7 @@ var
   Obj: TJSObjectLiteral;
   Prop: TJSObjectLiteralElement;
   aResolver: TPas2JSResolver;
-  Scope: TPasProcTypeScope;
+  Scope: TPas2JSProcTypeScope;
   SpecializeNeedsDelay: Boolean;
   FuncSt: TJSFunctionDeclarationStatement;
   AssignSt: TJSSimpleAssignStatement;
@@ -15420,7 +15503,7 @@ begin
   if El.Parent is TProcedureBody then
     RaiseNotSupported(El,AContext,20181231112029);
 
-  Scope:=El.CustomData as TPasProcTypeScope;
+  Scope:=El.CustomData as TPas2JSProcTypeScope;
   SpecializeNeedsDelay:=(Scope<>nil)
            and (aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil);
 
@@ -15532,7 +15615,7 @@ var
 
 var
   aResolver: TPas2JSResolver;
-  Scope: TPasArrayScope;
+  Scope: TPas2JSArrayScope;
   SpecializeNeedsDelay: Boolean;
   AssignSt: TJSSimpleAssignStatement;
   CallName, ArrName: String;
@@ -15566,7 +15649,7 @@ begin
   writeln('TPasToJSConverter.ConvertArrayType ',GetObjName(El));
   {$ENDIF}
 
-  Scope:=El.CustomData as TPasArrayScope;
+  Scope:=El.CustomData as TPas2JSArrayScope;
   SpecializeNeedsDelay:=(Scope<>nil)
            and (aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil);
 
@@ -16750,6 +16833,7 @@ begin
   if (C=TPasRecordType)
       or (C=TPasClassType) then
     begin
+    if (C=TPasClassType) and TPasClassType(El).IsExternal then exit;
     // pas.unitname.recordtype.$initSpec();
     Path:=CreateReferencePath(El,AContext,rpkPathAndName)+'.'+GetBIName(pbifnClassInitSpecialize);
     Call:=CreateCallExpression(El);

packages/pastojs/tests/tcgenerics.pas

@@ -47,6 +47,7 @@ type
     procedure TestGen_ExtClass_GenJSValueAssign;
     procedure TestGen_ExtClass_AliasMemberType;
     Procedure TestGen_ExtClass_RTTI;
+    procedure TestGen_ExtClass_UnitImplRec;
 
     // class interfaces
     procedure TestGen_ClassInterface_Corba;
@@ -79,6 +80,8 @@ type
     procedure TestGen_ArrayOfUnitImplRec;
 
     // generic procedure type
+    procedure TestGen_ProcType_ProcLocal;
+    procedure TestGen_ProcType_ProcLocal_RTTI;
     procedure TestGen_ProcType_ParamUnitImpl;
   end;
 
@@ -1324,6 +1327,70 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_ExtClass_UnitImplRec;
+begin
+  WithTypeInfo:=true;
+  StartProgram(true,[supTObject]);
+  AddModuleWithIntfImplSrc('UnitA.pas',
+  LinesToStr([
+  '{$mode objfpc}',
+  '{$modeswitch externalclass}',
+  'type',
+  '  generic TAnt<T> = class external name ''SET''',
+  '    x: T;',
+  '  end;',
+  '']),
+  LinesToStr([
+  'type',
+  '  TBird = record',
+  '    b: word;',
+  '  end;',
+  'var',
+  '  f: specialize TAnt<TBird>;',
+  'begin',
+  '  f.x.b:=f.x.b+10;',
+  '']));
+  Add([
+  'uses UnitA;',
+  'begin',
+  'end.']);
+  ConvertProgram;
+  CheckUnit('UnitA.pas',
+    LinesToStr([ // statements
+    'rtl.module("UnitA", ["system"], function () {',
+    '  var $mod = this;',
+    '  var $impl = $mod.$impl;',
+    '  $mod.$rtti.$ExtClass("TAnt$G1", {',
+    '    jsclass: "SET"',
+    '  });',
+    '  $mod.$init = function () {',
+    '    $impl.f.x.b = $impl.f.x.b + 10;',
+    '  };',
+    '}, null, function () {',
+    '  var $mod = this;',
+    '  var $impl = $mod.$impl;',
+    '  rtl.recNewT($impl, "TBird", function () {',
+    '    this.b = 0;',
+    '    this.$eq = function (b) {',
+    '      return this.b === b.b;',
+    '    };',
+    '    this.$assign = function (s) {',
+    '      this.b = s.b;',
+    '      return this;',
+    '    };',
+    '    var $r = $mod.$rtti.$Record("TBird", {});',
+    '    $r.addField("b", rtl.word);',
+    '  });',
+    '  $impl.f = null;',
+    '});']));
+  CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
+    LinesToStr([ // statements
+    //'pas.UnitA.TAnt$G1.$initSpec();',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_ClassInterface_Corba;
 begin
   StartProgram(false);
@@ -2044,6 +2111,61 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_ProcType_ProcLocal;
+begin
+  StartProgram(false);
+  Add([
+  'procedure Fly(w: word);',
+  'begin',
+  'end;',
+  'procedure Run(w: word);',
+  'type generic TProc<T> = procedure(a: T);',
+  'var p: specialize TProc<word>;',
+  'begin',
+  '  p:=@Fly;',
+  '  p(w);',
+  'end;',
+  'begin',
+  'end.']);
+  ConvertProgram;
+  CheckSource('TestGen_ProcType_ProcLocal',
+    LinesToStr([ // statements
+    'this.Fly = function (w) {',
+    '};',
+    'this.Run = function (w) {',
+    '  var p = null;',
+    '  p = $mod.Fly;',
+    '  p(w);',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
+procedure TTestGenerics.TestGen_ProcType_ProcLocal_RTTI;
+begin
+  WithTypeInfo:=true;
+  StartProgram(false);
+  Add([
+  'procedure Fly(w: word);',
+  'begin',
+  'end;',
+  'procedure Run(w: word);',
+  'type generic TProc<T> = procedure(a: T);',
+  'var',
+  '  p: specialize TProc<word>;',
+  '  t: Pointer;',
+  'begin',
+  '  p:=@Fly;',
+  '  p(w);',
+  '  t:=typeinfo(p);',
+  'end;',
+  'begin',
+  'end.']);
+  SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
+  ConvertProgram;
+end;
+
 procedure TTestGenerics.TestGen_ProcType_ParamUnitImpl;
 begin
   WithTypeInfo:=true;