fcl-passrc: generic reference to proc type

git-svn-id: trunk@43164 -

packages/fcl-passrc/src/pasresolver.pp

@@ -12239,6 +12239,7 @@ begin
   else
     begin
     IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
+
     if (not HasDot) and IsClassConDestructor then
       begin
       if ProcName='' then
@@ -15565,6 +15566,12 @@ type
       ParamElType:=TPasArrayType(ParamLoType).ElType;
       Infer(Arr,Arr.ElType,ParamElType,ResolveAliasType(ParamElType),
             NeedVar,true,IsDelphi,InferenceParams,TemplTypes,ErrorPos);
+      end
+    else
+      begin
+      {$IFDEF VerbosePasResolver}
+      //writeln('Infer ArgType=',GetObjName(ArgType),' ParamLoType=',GetObjName(ParamLoType));
+      {$ENDIF}
       end;
   end;
 

packages/fcl-passrc/src/pparser.pp

@@ -4354,6 +4354,36 @@ function TPasParser.ParseGenericTypeDecl(Parent: TPasElement;
       end;
   end;
 
+  procedure ParseProcType(const TypeName: string;
+    const NamePos: TPasSourcePos; TypeParams: TFPList;
+    IsReferenceTo: boolean);
+  var
+    ProcTypeEl: TPasProcedureType;
+    ProcType: TProcType;
+  begin
+    case CurToken of
+    tkFunction:
+      begin
+      ProcTypeEl := CreateFunctionType(TypeName, 'Result', Parent, False,
+                                       NamePos, TypeParams);
+      ProcType:=ptFunction;
+      end;
+    tkprocedure:
+      begin
+      ProcTypeEl := TPasProcedureType(CreateElement(TPasProcedureType,
+                          TypeName, Parent, visDefault, NamePos, TypeParams));
+      ProcType:=ptProcedure;
+      end;
+    else
+      ParseExcTokenError('procedure or function');
+    end;
+    ProcTypeEl.IsReferenceTo:=IsReferenceTo;
+    if AddToParent and (Parent is TPasDeclarations) then
+      TPasDeclarations(Parent).Functions.Add(ProcTypeEl);
+    InitGenericType(ProcTypeEl,TypeParams);
+    ParseProcedureOrFunction(ProcTypeEl, ProcTypeEl, ProcType, True);
+  end;
+
 var
   TypeName, AExternalNameSpace, AExternalName: String;
   NamePos: TPasSourcePos;
@@ -4361,8 +4391,6 @@ var
   ClassEl: TPasClassType;
   RecordEl: TPasRecordType;
   ArrEl: TPasArrayType;
-  ProcTypeEl: TPasProcedureType;
-  ProcType: TProcType;
   i: Integer;
   AObjKind: TPasObjKind;
 begin
@@ -4433,24 +4461,17 @@ begin
        Engine.FinishScope(stTypeDef,ArrEl);
        end;
     tkprocedure,tkfunction:
-      begin
-      if CurToken=tkFunction then
+      ParseProcType(TypeName,NamePos,TypeParams,false);
+    tkIdentifier:
+      if CurTokenIsIdentifier('reference') then
         begin
-        ProcTypeEl := CreateFunctionType(TypeName, 'Result', Parent, False,
-                                         NamePos, TypeParams);
-        ProcType:=ptFunction;
+        NextToken;
+        CheckToken(tkto);
+        NextToken;
+        ParseProcType(TypeName,NamePos,TypeParams,true);
         end
       else
-        begin
-        ProcTypeEl := TPasProcedureType(CreateElement(TPasProcedureType,
-                            TypeName, Parent, visDefault, NamePos, TypeParams));
-        ProcType:=ptProcedure;
-        end;
-      if AddToParent and (Parent is TPasDeclarations) then
-        TPasDeclarations(Parent).Functions.Add(ProcTypeEl);
-      InitGenericType(ProcTypeEl,TypeParams);
-      ParseProcedureOrFunction(ProcTypeEl, ProcTypeEl, ProcType, True);
-      end;
+        ParseExcTypeParamsNotAllowed;
     else
       ParseExcTypeParamsNotAllowed;
     end;

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -141,12 +141,12 @@ type
     procedure TestGenProc_TypeParamWithDefaultParamDelphiFail;
     procedure TestGenProc_Inference_NeedExplicitFail;
     procedure TestGenProc_Inference_Overload;
-    // ToDo procedure TestGenProc_Inference_OverloadForward;
+    procedure TestGenProc_Inference_OverloadForward;
     procedure TestGenProc_Inference_Var_Overload;
     //procedure TestGenProc_Inference_Widen;
     procedure TestGenProc_Inference_DefaultValue;
     procedure TestGenProc_Inference_DefaultValueMismatch;
-    procedure TestGenProc_Inference_ProcT; // ToDo
+    procedure TestGenProc_Inference_ProcT;
     procedure TestGenProc_Inference_Mismatch;
     procedure TestGenProc_Inference_ArrayOfT;
     // ToDo procedure TestGenProc_Inference_ProcType;
@@ -160,7 +160,6 @@ type
     procedure TestGenMethod_NestedSelf;
     procedure TestGenMethod_OverloadTypeParamCnt;
     procedure TestGenMethod_OverloadArgs;
-    // ToDo: procedure TestGenMethod_NestedProcDelphiFail;  Delphi 10.3 does not support nested procs
   end;
 
 implementation
@@ -2099,6 +2098,34 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGenProc_Inference_OverloadForward;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'procedure {#A}Run<S>(a: S; b: boolean); forward; overload;',
+  'procedure {#B}Run<T>(a: T; w: word); forward; overload;',
+  'procedure {#C}Run<U>(a: U; b: U); forward; overload;',
+  'procedure {#A2}Run<S>(a: S; b: boolean); overload;',
+  'begin',
+  '  {@A}Run(1,true);', // non generic take precedence
+  '  {@B}Run(2,word(3));', // non generic take precedence
+  '  {@C}Run(''foo'',''bar'');',
+  'end;',
+  'procedure {#B2}Run<T>(a: T; w: word); overload;',
+  'begin',
+  'end;',
+  'procedure {#C2}Run<U>(a: U; b: U); overload;',
+  'begin',
+  'end;',
+  'begin',
+  '  {@A}Run(1,true);', // non generic take precedence
+  '  {@B}Run(2,word(3));', // non generic take precedence
+  '  {@C}Run(''foo'',''bar'');',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGenProc_Inference_Var_Overload;
 begin
   StartProgram(false);
@@ -2160,13 +2187,11 @@ end;
 
 procedure TTestResolveGenerics.TestGenProc_Inference_ProcT;
 begin
-  exit;
-
   StartProgram(false);
   Add([
   '{$mode delphi}',
   'type',
-  '  TProc<T> = procedure(a: T);',
+  '  TProc<S> = reference to procedure(a: S);',
   '  TObject = class',
   '    procedure {#A}Run<T: class>(a: TProc<T>);',
   '  end;',
@@ -2177,7 +2202,7 @@ begin
   'var obj: TObject;',
   'begin',
   '  obj.{@A}Run<TBird>(procedure(Bird: TBird) begin end);',
-  '  obj.{@A}Run(procedure(Bird: TBird) begin end);', // not supported by Delphi
+  //'  obj.{@A}Run(procedure(Bird: TBird) begin end);', // not supported by Delphi
   '']);
   ParseProgram;
 end;