From ae0eef033bba7cce44512d981a4bdb4147a9e041 Mon Sep 17 00:00:00 2001 From: Mike Date: Sun, 6 Sep 2026 15:20:16 +0300 Subject: [PATCH 1/2] generics: defer constraint checks for implementation-header parameters (fixes upstream#41770) A Delphi-style implementation of a generic routine does not repeat the constraints of its declaration. While the implementation header is parsed, the fresh type parameter is still an undefineddef, and the constraint check rejected it ("Class type expected, but got T") before it could be matched with the already validated declaration. Skip the check only for an undefined generic parameter of an implementation header when a generic declaration with the same name and arity exists; complete header matching is still required afterwards. FPC issue: https://gitlab.com/freepascal.org/fpc/source/-/issues/41770 Co-Authored-By: Claude Fable 5.1 --- compiler/pgenutil.pas | 47 +++++++++++++++++++++++++++++++ tests/webtbs/tw41770.pp | 62 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 109 insertions(+) create mode 100644 tests/webtbs/tw41770.pp diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas index a541953d7c3..b332a28f2c5 100644 --- a/compiler/pgenutil.pas +++ b/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 } diff --git a/tests/webtbs/tw41770.pp b/tests/webtbs/tw41770.pp new file mode 100644 index 00000000000..ab7d8b6778b --- /dev/null +++ b/tests/webtbs/tw41770.pp @@ -0,0 +1,62 @@ +program tw41770; + +{$mode delphi} + +type + TBase = class + Value: LongInt; + end; + + TDerived = class(TBase); + + TGeneric = class + Item: T; + end; + + TWrapper = class + class procedure Observe(Box: TGeneric); static; + class function Echo(Box: TGeneric): TGeneric; static; overload; + class function Echo(Value: LongInt): LongInt; static; overload; + end; + +var + Observed: TBase; + +class procedure TWrapper.Observe(Box: TGeneric); +begin + Observed := Box.Item; +end; + +class function TWrapper.Echo(Box: TGeneric): TGeneric; +begin + Result := Box; +end; + +class function TWrapper.Echo(Value: LongInt): LongInt; +begin + Result := Value + 1; +end; + +var + Box: TGeneric; + Item: TDerived; +begin + Box := TGeneric.Create; + Item := TDerived.Create; + try + Item.Value := 41770; + Box.Item := Item; + TWrapper.Observe(Box); + if Observed <> Item then + Halt(1); + if TWrapper.Echo(Box) <> Box then + Halt(2); + if TWrapper.Echo(10) <> 11 then + Halt(3); + if TWrapper.Echo(Box).Item.Value <> 41770 then + Halt(4); + finally + Item.Free; + Box.Free; + end; +end. From d2049daf84f57ea96e51609cb6812f062be018ec Mon Sep 17 00:00:00 2001 From: Mike Date: Mon, 7 Sep 2026 12:42:29 +0300 Subject: [PATCH 2/2] Test generic constraint deferral boundaries Keep a valid implementation-header/runtime control and reject invalid concrete specialization at the call site, invalid body specialization and a mismatched implementation signature. These cover distinct phases rather than repeating the accepted example. --- tests/webtbs/tw41770.pp | 1 + tests/webtbs/tw41770a.pp | 19 +++++++++++++++++++ tests/webtbs/tw41770b.pp | 21 +++++++++++++++++++++ tests/webtbs/tw41770c.pp | 19 +++++++++++++++++++ 4 files changed, 60 insertions(+) create mode 100644 tests/webtbs/tw41770a.pp create mode 100644 tests/webtbs/tw41770b.pp create mode 100644 tests/webtbs/tw41770c.pp diff --git a/tests/webtbs/tw41770.pp b/tests/webtbs/tw41770.pp index ab7d8b6778b..a0c5ff96929 100644 --- a/tests/webtbs/tw41770.pp +++ b/tests/webtbs/tw41770.pp @@ -59,4 +59,5 @@ class function TWrapper.Echo(Value: LongInt): LongInt; Item.Free; Box.Free; end; + writeln('ok'); end. diff --git a/tests/webtbs/tw41770a.pp b/tests/webtbs/tw41770a.pp new file mode 100644 index 00000000000..8032260f436 --- /dev/null +++ b/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 = class end; + TWrapper = class + class procedure Observe(Box: TBox); static; + end; + +class procedure TWrapper.Observe(Box: TBox); +begin +end; + +begin + TWrapper.Observe(nil); +end. diff --git a/tests/webtbs/tw41770b.pp b/tests/webtbs/tw41770b.pp new file mode 100644 index 00000000000..6a2e80f488b --- /dev/null +++ b/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 = class end; + TWrapper = class + class procedure Observe(Box: TBox); static; + end; + +class procedure TWrapper.Observe(Box: TBox); +var + Invalid: TBox; +begin + Invalid := nil; +end; + +begin +end. diff --git a/tests/webtbs/tw41770c.pp b/tests/webtbs/tw41770c.pp new file mode 100644 index 00000000000..6d6b956c1a8 --- /dev/null +++ b/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 = class end; + TWrapper = class + class function Echo(Box: TBox): TBox; static; + end; + +class function TWrapper.Echo(Box: TBox): TBase; +begin + Result := nil; +end; + +begin +end.