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: https://svn.freepascal.org/svn/fpc/branches/fixes_3_2@48653 3ad0048d-3df7-0310-abae-a5850022a9f2

6 files changed, 128 insertions, 3 deletions

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<T> = 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<T> of object;
+    function Foo(const X: T): G<T>;
+end;
+
+function G<T>.Foo(const X: T): G<T>;
+begin
+    result := G<T>.Create;
+    result.X := X
+end;
+
+begin
+    G<Integer>.F := G<Integer>.Create.Foo;
+    if G<Integer>.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<T> = 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<T> of object;
+    function Foo(const aX: T): specialize G<T>;
+end;
+
+function G.Foo(const aX: T): specialize G<T>;
+begin
+    result := specialize G<T>.Create;
+    result.X := aX
+end;
+
+begin
+    specialize G<Integer>.F := @specialize G<Integer>.Create.Foo;
+    if specialize G<Integer>.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.