generics: defer constraint checks for implementation-header parameters (fixes upstream#41770)

compiler/pgenutil.pas

@@ -339,6 +339,44 @@ implementation
         intffound : boolean;
         filepos : tfileposinfo;
         is_const : boolean;
+
+      function is_implementation_generic_parameter(def:tstoreddef):boolean;
+        var
+          currentpd,
+          declpd : tprocdef;
+          i,j : longint;
+          samenames : boolean;
+        begin
+          result:=false;
+          if parse_only or assigned(current_procinfo) or
+              not assigned(current_genericdef) or
+              (current_genericdef.typ<>procdef) then
+            exit;
+          currentpd:=tprocdef(current_genericdef);
+          if not currentpd.is_generic_param(def) or
+              not assigned(currentpd.genericparas) or
+              not assigned(currentpd.procsym) then
+            exit;
+          for i:=0 to tprocsym(currentpd.procsym).procdeflist.count-1 do
+            begin
+              declpd:=tprocdef(tprocsym(currentpd.procsym).procdeflist[i]);
+              if (declpd.procsym<>currentpd.procsym) or
+                  not declpd.forwarddef or not declpd.is_generic or
+                  not (declpd.interfacedef or assigned(declpd.struct)) or
+                  (declpd.genericparas.count<>currentpd.genericparas.count) then
+                continue;
+              samenames:=true;
+              for j:=0 to currentpd.genericparas.count-1 do
+                if tsym(declpd.genericparas[j]).name<>
+                    tsym(currentpd.genericparas[j]).name then
+                  begin
+                    samenames:=false;
+                    break;
+                  end;
+              if samenames then
+                exit(true);
+            end;
+        end;
       begin
         { check whether the given specialization parameters fit to the eventual
           constraints of the generic }
@@ -379,6 +417,15 @@ implementation
             { test constraints for non-const params }
             if not genericdef.is_generic_param_const(i) then
               begin
+                { Constraints are only written on a routine declaration in
+                  Delphi-style syntax. While parsing its implementation header,
+                  the matching parameter is therefore still an undefineddef.
+                  The declaration has already validated the specialization and
+                  proc_add_definition will still require the complete headers
+                  to match. }
+                if (paradef.typ=undefineddef) and
+                    is_implementation_generic_parameter(paradef) then
+                  continue;
                 formaldef:=tstoreddef(ttypesym(genericdef.genericparas[i]).typedef);
                 if formaldef.typ=undefineddef then
                   { the parameter is of unspecified type, so no need to check }

tests/webtbs/tw41770.pp

@@ -0,0 +1,63 @@
+program tw41770;
+
+{$mode delphi}
+
+type
+  TBase = class
+    Value: LongInt;
+  end;
+
+  TDerived = class(TBase);
+
+  TGeneric<T: TBase> = class
+    Item: T;
+  end;
+
+  TWrapper = class
+    class procedure Observe<T: TBase>(Box: TGeneric<T>); static;
+    class function Echo<T: TBase>(Box: TGeneric<T>): TGeneric<T>; static; overload;
+    class function Echo<T>(Value: LongInt): LongInt; static; overload;
+  end;
+
+var
+  Observed: TBase;
+
+class procedure TWrapper.Observe<T>(Box: TGeneric<T>);
+begin
+  Observed := Box.Item;
+end;
+
+class function TWrapper.Echo<T>(Box: TGeneric<T>): TGeneric<T>;
+begin
+  Result := Box;
+end;
+
+class function TWrapper.Echo<T>(Value: LongInt): LongInt;
+begin
+  Result := Value + 1;
+end;
+
+var
+  Box: TGeneric<TDerived>;
+  Item: TDerived;
+begin
+  Box := TGeneric<TDerived>.Create;
+  Item := TDerived.Create;
+  try
+    Item.Value := 41770;
+    Box.Item := Item;
+    TWrapper.Observe<TDerived>(Box);
+    if Observed <> Item then
+      Halt(1);
+    if TWrapper.Echo<TDerived>(Box) <> Box then
+      Halt(2);
+    if TWrapper.Echo<TDerived>(10) <> 11 then
+      Halt(3);
+    if TWrapper.Echo<TDerived>(Box).Item.Value <> 41770 then
+      Halt(4);
+  finally
+    Item.Free;
+    Box.Free;
+  end;
+  writeln('ok');
+end.

tests/webtbs/tw41770a.pp

@@ -0,0 +1,19 @@
+{ %fail }
+{$mode delphi}
+
+{ A valid implementation header must not erase the declaration's constraint
+  when a concrete specialization is later requested. }
+type
+  TBase = class end;
+  TBox<T: TBase> = class end;
+  TWrapper = class
+    class procedure Observe<T: TBase>(Box: TBox<T>); static;
+  end;
+
+class procedure TWrapper.Observe<T>(Box: TBox<T>);
+begin
+end;
+
+begin
+  TWrapper.Observe<TObject>(nil);
+end.

tests/webtbs/tw41770b.pp

@@ -0,0 +1,21 @@
+{ %fail }
+{$mode delphi}
+
+{ The deferral belongs to implementation headers, not arbitrary
+  specializations appearing in the implementation body. }
+type
+  TBase = class end;
+  TBox<T: TBase> = class end;
+  TWrapper = class
+    class procedure Observe<T: TBase>(Box: TBox<T>); static;
+  end;
+
+class procedure TWrapper.Observe<T>(Box: TBox<T>);
+var
+  Invalid: TBox<TObject>;
+begin
+  Invalid := nil;
+end;
+
+begin
+end.

tests/webtbs/tw41770c.pp

@@ -0,0 +1,19 @@
+{ %fail }
+{$mode delphi}
+
+{ Matching a name and generic arity is only a reason to defer constraints;
+  the complete routine signature must still match its declaration. }
+type
+  TBase = class end;
+  TBox<T: TBase> = class end;
+  TWrapper = class
+    class function Echo<T: TBase>(Box: TBox<T>): TBox<T>; static;
+  end;
+
+class function TWrapper.Echo<T>(Box: TBox<T>): TBase;
+begin
+  Result := nil;
+end;
+
+begin
+end.