fcl-passrc: resolver: objfpc: canonical alias to spec classtype

git-svn-id: trunk@43219 -

packages/fcl-passrc/src/pasresolver.pp

@@ -17146,25 +17146,14 @@ end;
 function TPasResolver.SpecializeTypeRef(GenEl, SpecEl: TPasElement;
   GenTypeRef: TPasType): TPasType;
 var
-  GenParent, SpecParent, Ref: TPasElement;
+  Ref: TPasElement;
 begin
   if GenTypeRef.Name='' then
     RaiseNotYetImplemented(20190813213555,GenEl,GetObjPath(GenTypeRef));
-  if GenEl.HasParent(GenTypeRef) then
-    begin
-    GenParent:=GenEl.Parent;
-    SpecParent:=SpecEl.Parent;
-    while GenParent<>GenTypeRef do
-      begin
-      GenParent:=GenParent.Parent;
-      SpecParent:=SpecParent.Parent;
-      end;
-    Ref:=SpecParent;
-    end
-  else
-    Ref:=FindElement(GenTypeRef.Name);
+  Ref:=FindElement(GenTypeRef.Name);
   if not (Ref is TPasType) then
     RaiseNotYetImplemented(20190812021538,GenEl,GetObjName(Ref));
+  if SpecEl=nil then ;
   Result:=TPasType(Ref);
 end;
 
@@ -17990,7 +17979,7 @@ var
   HeaderScope: TPasGenericParamsScope;
   TemplType: TPasGenericTemplateType;
   GenericTemplateTypes: TFPList;
-  GenScope: TPasClassScope;
+  SpecClassScope: TPasClassScope;
 begin
   GenericTemplateTypes:=GenEl.GenericTemplateTypes;
   SpecEl.ObjKind:=GenEl.ObjKind;
@@ -18011,7 +18000,7 @@ begin
   // ancestor+interfaces
   if SpecializedItem<>nil then
     begin
-    // ancestor can be specialized types. For example: = class(TAncestor<T>)
+    // ancestor can be a specialized type. For example: = class(TAncestor<T>)
     // -> create a scope with the specialized parameters
     HeaderScope:=TPasGenericParamsScope.Create;
     SpecializedItem.HeaderScope:=HeaderScope;
@@ -18038,16 +18027,21 @@ begin
     end;
 
   FinishAncestors(SpecEl);
+  // Note: class scope was created by FinishAncestors
+  SpecClassScope:=NoNil(SpecEl.CustomData) as TPasClassScope;
 
-  // Note: class scope is created by FinishAncestors
-  GenScope:=NoNil(SpecEl.CustomData) as TPasClassScope;
-  if GenScope.SpecializedFromItem<>nil then
+  if SpecClassScope.SpecializedFromItem<>nil then
     RaiseNotYetImplemented(20190816215413,SpecEl);
   if SpecializedItem<>nil then
     begin
-    GenScope.SpecializedFromItem:=SpecializedItem;
+    SpecClassScope.SpecializedFromItem:=SpecializedItem;
     AddSpecializedTemplateIdentifiers(GenericTemplateTypes,
-                                      SpecializedItem,GenScope,false);
+                                      SpecializedItem,SpecClassScope,false);
+    if not (msDelphi in CurrentParser.CurrentModeswitches) then
+      begin
+      // ObjFPC: add canonical type alias
+      SpecClassScope.AddIdentifier(GenEl.Name,SpecEl,pikSimple);
+      end;
     end;
   // specialize sub elements
   SpecializeMembers(GenEl,SpecEl);

packages/pastojs/tests/tcgenerics.pas

@@ -25,6 +25,10 @@ type
     Procedure TestGen_Class_TypeInfo;
     Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
     Procedure TestGen_Class_ClassProperty;
+    Procedure TestGen_Class_ClassProc_ObjFPC;
+    //Procedure TestGen_Class_ClassProc_Delphi;
+    //Procedure TestGen_Class_ReferGenClass_DelphiFail;
+    Procedure TestGen_Class_ClassConstructor;
     // ToDo: rename local const T
 
     // generic external class
@@ -373,6 +377,141 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_Class_ClassProc_ObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  generic TPoint<T> = class',
+  '    class var x: T;',
+  '    class procedure Fly; static;',
+  '    class procedure Run;',
+  '  end;',
+  'class procedure Tpoint.Fly;',
+  'begin',
+  //'  x:=x+3;',
+  '  tpoint.x:=tpoint.x+4;',
+  //'  Fly;',
+  '  tpoint.Fly;',
+  //'  Run;',
+  '  tpoint.Run;',
+  'end;',
+  'class procedure TPoint.Run;',
+  'begin',
+  '  x:=x+5;',
+  '  tpoint.x:=tpoint.x+6;',
+  '  Fly;',
+  '  tpoint.Fly;',
+  '  Run;',
+  '  tpoint.Run;',
+  'end;',
+  'var p: specialize TPoint<word>;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Class_ClassProc',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TPoint$G1", $mod.TObject, function () {',
+    '  this.x = 0;',
+    '  this.Fly = function () {',
+    //'    $mod.TPoint$G1.x = $mod.TPoint$G1.x + 3;',
+    '    $mod.TPoint$G1.x = $mod.TPoint$G1.x + 4;',
+    '    $mod.TPoint$G1.Fly();',
+    '    $mod.TPoint$G1.Run();',
+    '  };',
+    '  this.Run = function () {',
+    '    $mod.TPoint$G1.x = this.x + 5;',
+    '    $mod.TPoint$G1.x = $mod.TPoint$G1.x + 6;',
+    '    this.Fly();',
+    '    $mod.TPoint$G1.Fly();',
+    '    this.Run();',
+    '    $mod.TPoint$G1.Run();',
+    '  };',
+    '});',
+    'this.p = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
+procedure TTestGenerics.TestGen_Class_ClassConstructor;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  generic TPoint<T> = class',
+  '    class var x: T;',
+  '    class procedure Fly; static;',
+  '    class constructor Init;',
+  '  end;',
+  'var count: word;',
+  'class procedure Tpoint.Fly;',
+  'begin',
+  'end;',
+  'class constructor tpoint.init;',
+  'begin',
+  '  count:=count+1;',
+  '  x:=3;',
+  '  tpoint.x:=4;',
+  '  fly;',
+  '  tpoint.fly;',
+  'end;',
+  'var',
+  '  r: specialize TPoint<word>;',
+  '  s: specialize TPoint<smallint>;',
+  'begin',
+  '  r.x:=10;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Class_ClassConstructor',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TPoint$G1", $mod.TObject, function () {',
+    '  this.x = 0;',
+    '  this.Fly = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TPoint$G2", $mod.TObject, function () {',
+    '  this.x = 0;',
+    '  this.Fly = function () {',
+    '  };',
+    '});',
+    'this.count = 0;',
+    'this.r = null;',
+    'this.s = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '(function () {',
+    '  $mod.count = $mod.count + 1;',
+    '  $mod.TPoint$G1.x = 3;',
+    '  $mod.TPoint$G1.x = 4;',
+    '  $mod.TPoint$G1.Fly();',
+    '  $mod.TPoint$G1.Fly();',
+    '})();',
+    '(function () {',
+    '  $mod.count = $mod.count + 1;',
+    '  $mod.TPoint$G2.x = 3;',
+    '  $mod.TPoint$G2.x = 4;',
+    '  $mod.TPoint$G2.Fly();',
+    '  $mod.TPoint$G2.Fly();',
+    '})();',
+    '$mod.TPoint$G1.x = 10;',
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_ExtClass_Array;
 begin
   StartProgram(false);