* support arrayconstructornodes of procvars (mantis #15391)

git-svn-id: trunk@14468 -

.gitattributes

@@ -9527,6 +9527,7 @@ tests/webtbf/tw14946.pp svneol=native#text/plain
 tests/webtbf/tw15287.pp svneol=native#text/plain
 tests/webtbf/tw15288.pp svneol=native#text/plain
 tests/webtbf/tw15303.pp svneol=native#text/plain
+tests/webtbf/tw15391a.pp svneol=native#text/plain
 tests/webtbf/tw1599.pp svneol=native#text/plain
 tests/webtbf/tw1599b.pp svneol=native#text/plain
 tests/webtbf/tw1633.pp svneol=native#text/plain
@@ -10153,6 +10154,7 @@ tests/webtbs/tw15364.pp svneol=native#text/plain
 tests/webtbs/tw15370.pp svneol=native#text/plain
 tests/webtbs/tw15377.pp svneol=native#text/pascal
 tests/webtbs/tw1539.pp svneol=native#text/plain
+tests/webtbs/tw15391.pp svneol=native#text/plain
 tests/webtbs/tw15415.pp svneol=native#text/plain
 tests/webtbs/tw1567.pp svneol=native#text/plain
 tests/webtbs/tw1573.pp svneol=native#text/plain

compiler/htypechk.pas

@@ -1543,6 +1543,9 @@ implementation
 
 
     procedure para_allowed(var eq:tequaltype;p:tcallparanode;def_to:tdef);
+      var
+        acn: tarrayconstructornode;
+        tmpeq: tequaltype;
       begin
         { Note: eq must be already valid, it will only be updated! }
         case def_to.typ of
@@ -1594,6 +1597,34 @@ implementation
                    is_procvar_load(p.left) then
                   eq:=te_convert_l2;
             end;
+          arraydef :
+            begin
+              { an arrayconstructor of proccalls may have to be converted to
+                an array of procvars }
+              if ((m_tp_procvar in current_settings.modeswitches) or
+                  (m_mac_procvar in current_settings.modeswitches)) and
+                 (tarraydef(def_to).elementdef.typ=procvardef) and
+                 is_array_constructor(p.resultdef) and
+                 not is_variant_array(p.resultdef) then
+                begin
+                  acn:=tarrayconstructornode(p.left);
+                  if assigned(acn.left) then
+                    begin
+                      eq:=te_exact;
+                      while assigned(acn) and
+                            (eq<>te_incompatible) do
+                        begin
+                          if (acn.left.nodetype=calln) then
+                            tmpeq:=proc_to_procvar_equal(tprocdef(tcallnode(acn.left).procdefinition),tprocvardef(tarraydef(def_to).elementdef))
+                          else
+                            tmpeq:=compare_defs(acn.left.resultdef,tarraydef(def_to).elementdef,acn.left.nodetype);
+                          if tmpeq<eq then
+                            eq:=tmpeq;
+                          acn:=tarrayconstructornode(acn.right);
+                        end;
+                    end
+                end;
+            end;
         end;
       end;
 
@@ -1973,6 +2004,7 @@ implementation
         def_to   : tdef;
         currpt,
         pt       : tcallparanode;
+        tmpeq,
         eq       : tequaltype;
         convtype : tconverttype;
         pdtemp,

tests/webtbf/tw15391a.pp

@@ -0,0 +1,29 @@
+{ %fail }
+
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+type
+  FuncA = function : Integer of object;
+  ObjA = class
+    function Func1: Integer;
+    procedure Proc1(const Arr: Array of char);
+  end;
+
+var A : ObjA;
+
+function ObjA.Func1: Integer;
+begin
+  Result := 1;
+end;
+
+procedure ObjA.Proc1(const Arr: Array of char);
+begin
+end;
+
+begin
+  A := ObjA.Create;
+  A.Proc1([A.Func1]);
+  a.free;
+end.

tests/webtbs/tw15391.pp

@@ -0,0 +1,39 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+type
+  FuncA = function : Integer of object;
+  ObjA = class
+    function Func1: Integer;
+    procedure Proc1(const Arr: Array of FuncA);
+  end;
+
+var A : ObjA;
+
+procedure test(fa: funca);
+begin
+  if fa<>a.func1 then
+    halt(2);
+end;
+
+function ObjA.Func1: Integer;
+begin
+  Result := 1;
+end;
+
+procedure ObjA.Proc1(const Arr: Array of FuncA);
+begin
+  if (low(arr)<>0) or
+     (high(arr)<>1) or
+     assigned(arr[0]) or
+     (arr[1]<>a.func1) then
+    halt(1);
+end;
+
+begin
+  A := ObjA.Create;
+  A.Proc1([nil,A.Func1]);
+  test(a.func1);
+  a.free;
+end.