fcl-passrc: fixed generic method with Self do

packages/fcl-passrc/src/pasresolver.pp

@@ -2235,7 +2235,7 @@ type
     function HasExactType(const ResolvedEl: TPasResolverResult): boolean; // false if HiTypeEl was guessed, e.g. 1 guessed a btLongint
     function IndexOfGenericParam(Params: TPasExprArray): integer;
     procedure CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
-      ErrorEl: TPasElement);
+      PosEl: TPasElement);
     function CheckCallProcCompatibility(ProcType: TPasProcedureType;
       Params: TParamsExpr; RaiseOnError: boolean; SetReferenceFlags: boolean = false): integer;
     function CheckCallPropertyCompatibility(PropEl: TPasProperty;
@@ -22964,7 +22964,6 @@ begin
       [BaseTypeNames[ExprResolved.BaseType]],ErrorEl);
 
   Flags:=[];
-  CheckUseAsType(LoType,20190123113957,Expr);
   ClassRecScope:=nil;
   ExprScope:=nil;
   if LoType.ClassType=TPasClassOfType then
@@ -28424,7 +28423,7 @@ begin
 end;
 
 procedure TPasResolver.CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
-  ErrorEl: TPasElement);
+  PosEl: TPasElement);
 begin
   if aType=nil then exit;
   if aType is TPasGenericType then
@@ -28432,18 +28431,18 @@ begin
     if aType.ClassType=TPasClassType then
       begin
       if TPasClassType(aType).HelperForType<>nil then
-        RaiseHelpersCannotBeUsedAsType(id,ErrorEl);
+        RaiseHelpersCannotBeUsedAsType(id,PosEl);
       end;
     if (TPasGenericType(aType).GenericTemplateTypes<>nil)
         and (TPasGenericType(aType).GenericTemplateTypes.Count>0) then
       begin
       // ref to generic type without specialization
       if not (msDelphi in CurrentParser.CurrentModeswitches)
-          and (ErrorEl.HasParent(aType)) then
+          and (PosEl.HasParent(aType)) then
         // ObjFPC allows referring to parent without type params
       else
         RaiseMsg(id,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,
-            [ErrorEl.ElementTypeName],ErrorEl);
+            [PosEl.ElementTypeName],PosEl);
       end;
     end;
 end;

packages/pastojs/tests/tcgenerics.pas

@@ -27,13 +27,13 @@ type
     Procedure TestGen_ClassEmpty;
     Procedure TestGen_Class_EmptyMethod;
     Procedure TestGen_Class_TList;
-    Procedure TestGen_Class_TCustomList; // ToDo: with Self do Result:=Method()
+    Procedure TestGen_Class_TCustomList;
     Procedure TestGen_ClassAncestor;
     Procedure TestGen_Class_TypeInfo;
-    Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
+    Procedure TestGen_Class_TypeOverload;
     Procedure TestGen_Class_ClassProperty;
     Procedure TestGen_Class_ClassProc;
-    //Procedure TestGen_Record_ReferGenClass_DelphiFail; TBird<T> = class x:TBird; end;
+    Procedure TestGen_Class_ReferGenClass_DelphiFail;
     Procedure TestGen_Class_ClassConstructor;
     Procedure TestGen_Class_TypeCastSpecializesWarn;
     Procedure TestGen_Class_TypeCastSpecializesJSValueNoWarn;
@@ -92,6 +92,8 @@ type
     procedure TestGen_ProcType_ProcLocal;
     procedure TestGen_ProcType_Local_RTTI_Fail;
     procedure TestGen_ProcType_ParamUnitImpl;
+    // procedure TestGen_ProcType_TemplateCountOverload_ObjFPC; ObjFPC does not support that in FPC
+    procedure TestGen_ProcType_TemplateCountOverload_Delphi;
   end;
 
 implementation
@@ -574,7 +576,7 @@ begin
   'begin',
   '  Result:=PrepareAddingItem;',
   '  Result:=Self.PrepareAddingItem;',
-  //'  with Self do Result:=PrepareAddingItem;',
+  '  with Self do Result:=PrepareAddingItem;',
   'end;',
   'var l: TWordList;',
   'begin',
@@ -599,6 +601,7 @@ begin
     '    var Result = 0;',
     '    Result = this.PrepareAddingItem();',
     '    Result = this.PrepareAddingItem();',
+    '    Result = this.PrepareAddingItem();',
     '    return Result;',
     '  };',
     '}, "TList<System.Word>");',
@@ -688,8 +691,6 @@ end;
 
 procedure TTestGenerics.TestGen_Class_TypeOverload;
 begin
-  exit;// ToDo
-
   StartProgram(false);
   Add([
   '{$mode delphi}',
@@ -714,6 +715,14 @@ begin
     '  this.$final = function () {',
     '  };',
     '});',
+    'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
+    '  this.$init = function () {',
+    '    $mod.TObject.$init.call(this);',
+    '    this.m = 0;',
+    '  };',
+    '}, "TBird<System.Word>");',
+    'this.b = null;',
+    'this.e = null;',
     '']),
     LinesToStr([ // $mod.$main
     '']));
@@ -820,6 +829,24 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_Class_ReferGenClass_DelphiFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class end;',
+  '  TPoint<T> = class',
+  '    var x: TPoint;', // alowed in objfpc, forbidden in delphi
+  '  end;',
+  'var p: specialize TPoint<word>;',
+  'begin',
+  '']);
+  SetExpectedPasResolverError('Generics without specialization cannot be used as a type for a variable',
+     nGenericsWithoutSpecializationAsType);
+  ConvertProgram;
+end;
+
 procedure TTestGenerics.TestGen_Class_ClassConstructor;
 begin
   StartProgram(false);
@@ -2865,6 +2892,50 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_ProcType_TemplateCountOverload_Delphi;
+begin
+  WithTypeInfo:=true;
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TProc<T> = procedure(a, b: T);',
+  '  TProc<S,T> = procedure(a: S; b: T);',
+  'var',
+  '  p: TProc<word>;',
+  '  q: TProc<char,boolean>;',
+  'procedure Run(x,y: word);',
+  'begin',
+  'end;',
+  'procedure Fly(x: char; y: boolean);',
+  'begin',
+  'end;',
+  'begin',
+  '  p:=Run;',
+  '  q:=Fly;',
+  'end.']);
+  ConvertProgram;
+  CheckSource('TestGen_ProcType_TemplateCountOverload_Delphi',
+    LinesToStr([ // statements
+    'this.$rtti.$ProcVar("TProc<System.Word>", {',
+    '  procsig: rtl.newTIProcSig([["a", rtl.word], ["b", rtl.word]])',
+    '});',
+    'this.p = null;',
+    'this.$rtti.$ProcVar("TProc<System.Char,System.Boolean>", {',
+    '  procsig: rtl.newTIProcSig([["a", rtl.char], ["b", rtl.boolean]])',
+    '});',
+    'this.q = null;',
+    'this.Run = function (x, y) {',
+    '};',
+    'this.Fly = function (x, y) {',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.p = $mod.Run;',
+    '$mod.q = $mod.Fly;',
+    '']));
+end;
+
 Initialization
   RegisterTests([TTestGenerics]);
 end.