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

@@ -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

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

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;
 
 

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.

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.

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.

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.