From f455d66a751e1453feee2ded20459845d6993b7d Mon Sep 17 00:00:00 2001 From: svenbarth Date: Thu, 11 Feb 2021 21:30:38 +0000 Subject: [PATCH] Merged revision(s) 47794-47795, 47826 from trunk: * apply patch by Blaise.ru to allow record methods to be assigned to method variables as well (this is Delphi compatible) + added test ........ * apply patch by Blaise.ru to allow specializations for the result type of function and method variables + added tests ........ * fix for Mantis #38238: when creating a copy of a procdef for a procvar set the methodpointer flag also for methods of records + added test ........ git-svn-id: branches/fixes_3_2@48653 - --- .gitattributes | 4 +++ compiler/ptype.pas | 2 +- compiler/symdef.pas | 4 +-- tests/tbs/tb0681.pp | 23 ++++++++++++++++ tests/test/tgeneric106.pp | 23 ++++++++++++++++ tests/test/tgeneric107.pp | 23 ++++++++++++++++ tests/webtbs/tw38238.pp | 56 +++++++++++++++++++++++++++++++++++++++ 7 files changed, 132 insertions(+), 3 deletions(-) create mode 100644 tests/tbs/tb0681.pp create mode 100644 tests/test/tgeneric106.pp create mode 100644 tests/test/tgeneric107.pp create mode 100644 tests/webtbs/tw38238.pp diff --git a/.gitattributes b/.gitattributes index fd382e169b..400baa9323 100644 --- a/.gitattributes +++ b/.gitattributes @@ -12942,6 +12942,7 @@ tests/tbs/tb0677.pp svneol=native#text/pascal tests/tbs/tb0678.pp svneol=native#text/pascal tests/tbs/tb0679.pp svneol=native#text/pascal tests/tbs/tb0680.pp svneol=native#text/pascal +tests/tbs/tb0681.pp svneol=native#text/pascal tests/tbs/tb205.pp svneol=native#text/plain tests/tbs/tb610.pp svneol=native#text/pascal tests/tbs/tb613.pp svneol=native#text/plain @@ -14456,6 +14457,8 @@ tests/test/tgeneric102.pp svneol=native#text/pascal tests/test/tgeneric103.pp svneol=native#text/pascal tests/test/tgeneric104.pp -text svneol=native#text/pascal tests/test/tgeneric105.pp svneol=native#text/pascal +tests/test/tgeneric106.pp svneol=native#text/pascal +tests/test/tgeneric107.pp svneol=native#text/pascal tests/test/tgeneric11.pp svneol=native#text/plain tests/test/tgeneric12.pp svneol=native#text/plain tests/test/tgeneric13.pp svneol=native#text/plain @@ -17824,6 +17827,7 @@ tests/webtbs/tw38069.pp svneol=native#text/pascal tests/webtbs/tw38083.pp svneol=native#text/pascal tests/webtbs/tw3814.pp svneol=native#text/plain tests/webtbs/tw38151.pp svneol=native#text/pascal +tests/webtbs/tw38238.pp svneol=native#text/pascal tests/webtbs/tw3827.pp svneol=native#text/plain tests/webtbs/tw3829.pp svneol=native#text/plain tests/webtbs/tw3833.pp svneol=native#text/plain diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 328ab4e9e0..2b03fa6a11 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1567,7 +1567,7 @@ implementation if is_func then begin consume(_COLON); - single_type(pd.returndef,[]); + single_type(pd.returndef,[stoAllowSpecialization]); end; if try_to_consume(_OF) then begin diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 3926339289..283270fd09 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -5265,7 +5265,7 @@ implementation {$endif} if (typ=procdef) and (newtyp=procvardef) and - (owner.symtabletype=ObjectSymtable) then + (owner.symtabletype in [ObjectSymtable,recordsymtable]) then include(tprocvardef(result).procoptions,po_methodpointer); end; @@ -6032,7 +6032,7 @@ implementation begin { don't check assigned(_class), that's also the case for nested procedures inside methods } - result:=(owner.symtabletype=ObjectSymtable)and not no_self_node; + result:=(owner.symtabletype in [recordsymtable,ObjectSymtable]) and not no_self_node; end; diff --git a/tests/tbs/tb0681.pp b/tests/tbs/tb0681.pp new file mode 100644 index 0000000000..ab93efb232 --- /dev/null +++ b/tests/tbs/tb0681.pp @@ -0,0 +1,23 @@ +program tb0681; + +{$Mode Delphi} + +type R = record + var X: Integer; + function Foo: Integer; +end; + +function R.Foo: Integer; +begin + result := X +end; + +var F: function : Integer of object; + Z: R = (X:42); +begin + // EXPECTED: gets compiled + // ACTUAL: 'Error: Incompatible types' + F := Z.Foo; + if F() <> 42 then + Halt(1); +end. diff --git a/tests/test/tgeneric106.pp b/tests/test/tgeneric106.pp new file mode 100644 index 0000000000..adc5d209b3 --- /dev/null +++ b/tests/test/tgeneric106.pp @@ -0,0 +1,23 @@ +program tgeneric106; + +{$Mode Delphi} + +type G = class + var X: T; + // EXPECTED: gets compiled + // ACTUAL: 'Error: Generics without specialization cannot be used as a type for a variable' + class var F: function(const X: T) : G of object; + function Foo(const X: T): G; +end; + +function G.Foo(const X: T): G; +begin + result := G.Create; + result.X := X +end; + +begin + G.F := G.Create.Foo; + if G.F(42).X <> 42 then + halt(1); +end. diff --git a/tests/test/tgeneric107.pp b/tests/test/tgeneric107.pp new file mode 100644 index 0000000000..3f8e0eb41a --- /dev/null +++ b/tests/test/tgeneric107.pp @@ -0,0 +1,23 @@ +program tgeneric107; + +{$Mode ObjFpc} + +type generic G = class + var X: T; + // EXPECTED: gets compiled + // ACTUAL: 'Error: Generics without specialization cannot be used as a type for a variable' + class var F: function(const X: T) : specialize G of object; + function Foo(const aX: T): specialize G; +end; + +function G.Foo(const aX: T): specialize G; +begin + result := specialize G.Create; + result.X := aX +end; + +begin + specialize G.F := @specialize G.Create.Foo; + if specialize G.F(42).X <> 42 then + halt(1); +end. diff --git a/tests/webtbs/tw38238.pp b/tests/webtbs/tw38238.pp new file mode 100644 index 0000000000..a49daef1dc --- /dev/null +++ b/tests/webtbs/tw38238.pp @@ -0,0 +1,56 @@ +program tw38238; + +{$mode objfpc} +{$modeswitch advancedrecords} + +type + TCallback = procedure(AValue: longint) of object; + + TRec = record + Clb: TCallback; + procedure AddCallback(ACallback: TCallback); + procedure TriggerCallback(AValue: longint); + end; + + TRec2 = record + Value: longint; + Rec: TRec; + procedure CLB(AValue: longint); + procedure InitStuff; + end; + +procedure TRec.AddCallback(ACallback: TCallback); +begin + Clb:=ACallback; +end; + +procedure TRec.TriggerCallback(AValue: longint); +begin + if assigned(Clb) then + Clb(AValue); +end; + +procedure TRec2.CLB(AValue: longint); +begin + Value:=AValue; +end; + +procedure TRec2.InitStuff; +begin + Rec.AddCallback(@CLB); +end; + +var + Rec1, Rec2: TRec2; +begin + Rec1.InitStuff; + Rec2.InitStuff; + + Rec1.Rec.TriggerCallback(1234); + Rec2.Rec.TriggerCallback($0943); + + if Rec1.Value<>1234 then + Halt(1); + if Rec2.Value<>$0943 then + Halt(2); +end.