fcl-passrc: implicit function specialization with var params

git-svn-id: trunk@43150 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -204,6 +204,7 @@ const
   nImplMustNotRepeatConstraints = 3138;
   nCouldNotInferTypeArgXForMethodY = 3139;
   nInferredTypeXFromDiffArgsMismatchFromMethodY = 3140;
+  nParamOfThisTypeCannotHaveDefVal = 3141;
 
   // using same IDs as FPC
   nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@@ -355,6 +356,7 @@ resourcestring
   sImplMustNotRepeatConstraints = 'Implementations must not repeat constraints';
   sCouldNotInferTypeArgXForMethodY = 'Could not infer generic type argument "%s" for method "%s"';
   sInferredTypeXFromDiffArgsMismatchFromMethodY = 'Inferred type "%s" from different arguments mismatch for method "%s"';
+  sParamOfThisTypeCannotHaveDefVal = 'Parameters of this type cannot have default values';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }

packages/fcl-passrc/src/pasresolver.pp

@@ -8214,6 +8214,45 @@ begin
 end;
 
 procedure TPasResolver.FinishArgument(El: TPasArgument);
+
+  procedure CheckHasGenTemplRef(Arg: TPasArgument);
+
+    procedure Check(Parent: TPasElement; Cur: TPasType; TemplTypes: TFPList);
+    var
+      C: TClass;
+      Arr: TPasArrayType;
+    begin
+      if Cur=nil then exit;
+      C:=Cur.ClassType;
+      if C=TPasGenericTemplateType then
+        begin
+        if TemplTypes.IndexOf(Cur)>=0 then
+          RaiseMsg(20191007213121,nParamOfThisTypeCannotHaveDefVal,sParamOfThisTypeCannotHaveDefVal,[],El);
+        end
+      else if Cur.Parent<>Parent then
+        exit
+      else if C=TPasArrayType then
+        begin
+        Arr:=TPasArrayType(Cur);
+        Check(Arr,Arr.ElType,TemplTypes);
+        end;
+    end;
+
+  var
+    Proc: TPasProcedure;
+    TemplTypes: TFPList;
+  begin
+    if Arg.ArgType=nil then exit;
+    if not (Arg.Parent is TPasProcedureType) then exit;
+    if not (Arg.Parent.Parent is TPasProcedure) then exit;
+    Proc:=TPasProcedure(Arg.Parent.Parent);
+    TemplTypes:=GetProcTemplateTypes(Proc);
+    if TemplTypes=nil then exit;
+    Check(Arg,Arg.ArgType,TemplTypes);
+  end;
+
+var
+  IsDelphi: Boolean;
 begin
   if El.ArgType<>nil then
     CheckUseAsType(El.ArgType,20190123100049,El);
@@ -8221,7 +8260,12 @@ begin
     begin
     ResolveExpr(El.ValueExpr,rraRead);
     if El.ArgType<>nil then
+      begin
       CheckAssignCompatibility(El,El.ValueExpr,true);
+      IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
+      if IsDelphi then
+        CheckHasGenTemplRef(El);
+      end;
     end;
   EmitTypeHints(El,El.ArgType);
 end;
@@ -16335,7 +16379,6 @@ begin
   GenericEl:=SpecializedItem.GenericEl;
 
   // change scope
-  WriteScopesShort('AAA1 TPasResolver.SpecializeGenericIntf *******************');
   InitSpecializeScopes(GenericEl,OldScopeState);
   {$IFDEF VerbosePasResolver}
   WriteScopesShort('TPasResolver.SpecializeGenericIntf Init SpecEl='+SpecEl.FullName+' GenericEl='+GenericEl.FullName);
@@ -24757,10 +24800,9 @@ var
 begin
   Result:=cIncompatible;
 
-  NeedVar:=Param.Access in [argVar, argOut];
-
   ComputeArgumentAndExpr(Param,ParamResolved,Expr,ExprResolved,SetReferenceFlags);
 
+  NeedVar:=Param.Access in [argVar, argOut];
   if NeedVar then
     begin
     // Expr must be a variable
@@ -24804,6 +24846,11 @@ begin
         if Result<>cIncompatible then exit;
         end;
       end;
+    if (ParamResolved.BaseType=btContext)
+        and (ParamResolved.LoTypeEl.ClassType=TPasGenericTemplateType) then
+      exit(cGenericExact);
+
+    //writeln('TPasResolver.CheckParamCompatibility NeedVar ParamResolved=',GetResolverResultDbg(ParamResolved),' ExprResolved=',GetResolverResultDbg(ExprResolved));
     if RaiseOnError then
       RaiseIncompatibleTypeRes(20170216152452,nIncompatibleTypeArgNoVarParamMustMatchExactly,
         [IntToStr(ParamNo+1)],ExprResolved,ParamResolved,
@@ -26824,19 +26871,31 @@ function TPasResolver.HasExactType(const ResolvedEl: TPasResolverResult
   ): boolean;
 var
   IdentEl: TPasElement;
+  Expr: TPasExpr;
 begin
   IdentEl:=ResolvedEl.IdentEl;
-  if IdentEl=nil then exit(false);
-  if IdentEl is TPasVariable then
-    exit(TPasVariable(IdentEl).VarType<>nil)
-  else if IdentEl.ClassType=TPasArgument then
-    exit(TPasArgument(IdentEl).ArgType<>nil)
-  else if IdentEl.ClassType=TPasResultElement then
-    exit(TPasResultElement(IdentEl).ResultType<>nil)
-  else if IdentEl is TPasType then
-    Result:=true
-  else
-    Result:=false;
+  if IdentEl<>nil then
+    begin
+    if IdentEl is TPasVariable then
+      exit(TPasVariable(IdentEl).VarType<>nil)
+    else if IdentEl.ClassType=TPasArgument then
+      exit(TPasArgument(IdentEl).ArgType<>nil)
+    else if IdentEl.ClassType=TPasResultElement then
+      exit(TPasResultElement(IdentEl).ResultType<>nil)
+    else if IdentEl is TPasType then
+      exit(true)
+    else
+      exit(false);
+    end;
+  Expr:=ResolvedEl.ExprEl;
+  if Expr<>nil then
+    begin
+    if Expr.Kind in [pekNumber,pekString,pekNil,pekBoolConst] then
+      exit(true)
+    else
+      exit(false);
+    end;
+  Result:=false;
 end;
 
 function TPasResolver.IndexOfGenericParam(Params: TPasExprArray): integer;

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -138,12 +138,12 @@ type
     procedure TestGenProc_NestedFail;
     procedure TestGenProc_TypeParamCntOverload;
     procedure TestGenProc_TypeParamCntOverloadNoParams;
-    procedure TestGenProc_TypeParamWithDefaultParamDelphiFail; // ToDo
+    procedure TestGenProc_TypeParamWithDefaultParamDelphiFail;
     procedure TestGenProc_Inference_NeedExplicitFail;
-    procedure TestGenProc_Inference_Overload; // ToDo
-    //procedure TestGenProc_Inference_Var_Overload;
-    // ToDo procedure TestGenProc_Inference_NonGenericPrecedence;
-    // ToDo procedure TestGenProc_Inference_DefaultValueFail
+    procedure TestGenProc_Inference_Overload;
+    procedure TestGenProc_Inference_Var_Overload;
+    //procedure TestGenProc_Inference_Widen;
+    // ToDo procedure TestGenProc_Inference_DefaultValue
     procedure TestGenProc_Inference_ProcT;
     procedure TestGenProc_Inference_Mismatch;
     // ToDo procedure TestGenProc_Inference_ArrayOfT;
@@ -2049,8 +2049,6 @@ end;
 procedure TTestResolveGenerics.TestGenProc_TypeParamWithDefaultParamDelphiFail;
 begin
   // delphi 10.3 does not allow default values for args with generic types
-  exit;
-
   StartProgram(false);
   Add([
   '{$mode delphi}',
@@ -2059,7 +2057,7 @@ begin
   'end;',
   'begin',
   '']);
-  CheckResolverException('Parameters of this type cannot have default values',123);
+  CheckResolverException(sParamOfThisTypeCannotHaveDefVal,nParamOfThisTypeCannotHaveDefVal);
 end;
 
 procedure TTestResolveGenerics.TestGenProc_Inference_NeedExplicitFail;
@@ -2079,8 +2077,6 @@ end;
 
 procedure TTestResolveGenerics.TestGenProc_Inference_Overload;
 begin
-  exit;
-
   StartProgram(false);
   Add([
   '{$mode delphi}',
@@ -2094,13 +2090,39 @@ begin
   'begin',
   'end;',
   'begin',
-  '  {@A}Run(1,true);',
-  '  {@B}Run(2,3);',
+  '  {@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);
+  Add([
+  '{$mode delphi}',
+  'procedure {#A}Run<S>(var a: S; var b: boolean); overload;',
+  'begin',
+  'end;',
+  'procedure {#B}Run<T>(var a: T; var w: word); overload;',
+  'begin',
+  'end;',
+  'procedure {#C}Run<U>(var a: U; var b: U); overload;',
+  'begin',
+  'end;',
+  'var',
+  '  w: word;',
+  '  b: boolean;',
+  '  s: string;',
+  'begin',
+  '  {@A}Run(w,b);',
+  '  {@B}Run(s,w);',
+  '  {@C}Run(s,s);',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGenProc_Inference_ProcT;
 begin
   exit;

packages/fcl-passrc/tests/tcresolver.pas

@@ -6483,8 +6483,8 @@ begin
   StartProgram(false);
   Add([
   'type',
-  '  integer = longint;',
-  '  TValue = type longint;',
+  '  integer = word;',
+  '  TValue = type word;',
   '  TAliasValue = TValue;',
   'procedure DoIt(i: integer); external;',
   'procedure DoIt(i: TAliasValue); external;',