+ support for calling a method via a block: we capture the method as a

    procvar in the local state of the block, and then call it insde the
    generated invoke routine. We can't call it directly there, because
    due to visibility reasons it may not be accessible from a regular
    procedure (e.g. if it is a strict private method)

git-svn-id: branches/blocks@28234 -

.gitattributes

@@ -11118,6 +11118,8 @@ tests/test/tassignmentoperator1.pp svneol=native#text/pascal
 tests/test/tblock1.pp svneol=native#text/plain
 tests/test/tblock1a.pp svneol=native#text/plain
 tests/test/tblock1c.pp svneol=native#text/plain
+tests/test/tblock2.pp svneol=native#text/plain
+tests/test/tblock2a.pp svneol=native#text/plain
 tests/test/tbopr.pp svneol=native#text/plain
 tests/test/tbrtlevt.pp svneol=native#text/plain
 tests/test/tbsx1.pp svneol=native#text/plain

compiler/blockutl.pas

@@ -28,7 +28,7 @@ unit blockutl;
 interface
 
   uses
-    node,nld,
+    node,nld,ncnv,
     symtype,symdef;
 
   { accepts a loadnode for a procdef
@@ -48,10 +48,10 @@ interface
 implementation
 
   uses
-    verbose,globtype,cutils,
+    verbose,globtype,globals,cutils,constexp,
     pass_1,pparautl,fmodule,
     aasmdata,
-    ncnv,nmem,
+    nbas,ncon,nmem,nutils,
     symbase,symconst,symtable,symsym,symcreat,objcutil,objcdef,defutil,
     paramgr;
 
@@ -225,7 +225,10 @@ implementation
         end
       else
         begin
-          internalerror(2014071609);
+          { alias for the type to invoke the procvar, used in the symcreat
+            handling of tsk_block_invoke_procvar }
+          result.localst.insert(ctypesym.create('__FPC_BLOCK_INVOKE_PV_TYPE',orgpv));
+          result.synthetickind:=tsk_block_invoke_procvar;
         end;
     end;
 
@@ -265,6 +268,51 @@ implementation
     end;
 
 
+  { compose an on-stack block literal for a "procedure of object" }
+  function get_pascal_method_literal(blockliteraldef: tdef; blockisasym: tstaticvarsym; blockflags: longint; procvarnode: tnode; invokepd: tprocdef; orgpv: tprocvardef; descriptor: tstaticvarsym): tnode;
+    var
+      statement: tstatementnode;
+      literaltemp: ttempcreatenode;
+    begin
+      result:=internalstatements(statement);
+      { create new block literal structure }
+      literaltemp:=ctempcreatenode.create(blockliteraldef,blockliteraldef.size,tt_persistent,false);
+      addstatement(statement,literaltemp);
+      { temp.base.isa:=@blockisasym }
+      addstatement(statement,cassignmentnode.create(
+        genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'ISA'),
+        caddrnode.create(cloadnode.create(blockisasym,blockisasym.owner))));
+      { temp.base.flags:=blockflags }
+      addstatement(statement,cassignmentnode.create(
+        genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'FLAGS'),
+        genintconstnode(blockflags)));
+      { temp.base.reserved:=0 }
+      addstatement(statement,cassignmentnode.create(
+        genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'RESERVED'),
+        genintconstnode(0)));
+      { temp.base.invoke:=tmethod(@invokepd) }
+      addstatement(statement,cassignmentnode.create(
+        genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'INVOKE'),
+        ctypeconvnode.create_proc_to_procvar(
+          cloadnode.create_procvar(invokepd.procsym,invokepd,invokepd.owner))));
+      { temp.base.descriptor:=@descriptor }
+      addstatement(statement,cassignmentnode.create(
+        genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'DESCRIPTOR'),
+        caddrnode.create(cloadnode.create(descriptor,descriptor.owner))));
+      { temp.pv:=tmethod(@orgpd) }
+      addstatement(statement,cassignmentnode.create(
+        ctypeconvnode.create_explicit(genloadfield(ctemprefnode.create(literaltemp),'PV'),orgpv),
+          procvarnode.getcopy));
+      { and return the address of the temp }
+      addstatement(statement,caddrnode.create(ctemprefnode.create(literaltemp)));
+      { typecheck this now, because the current source may be written in TP/
+        Delphi/MacPas mode and the above node tree has been constructed for
+        ObjFPC mode, which has been set by replace_scanner (in Delphi, the
+        assignment to invoke would be without the proc_to_procvar conversion) }
+      typecheckpass(result);
+    end;
+
+
   function generate_block_for_procaddr(procloadnode: tloadnode): tnode;
     var
       procvarnode: tnode;
@@ -321,9 +369,7 @@ implementation
         end
       else
         begin
-          { local variable that gets initialised: create temp, initialise it,
-            return address of temp }
-          internalerror(2014071502);
+          result:=get_pascal_method_literal(blockliteraldef,blockisasym,blockflags,procvarnode,invokepd,orgpv,descriptor)
         end;
 
       procvarnode.free;

compiler/defcmp.pas

@@ -2180,30 +2180,38 @@ implementation
          if not(assigned(def1)) or not(assigned(def2)) then
            exit;
          { check for method pointer and local procedure pointer:
-             a) if one is a procedure of object, the other also has to be one
-             b) if one is a pure address, the other also has to be one
+             a) anything but procvars can be assigned to blocks
+             b) if one is a procedure of object, the other also has to be one
+                (except for block)
+             c) if one is a pure address, the other also has to be one
                 except if def1 is a global proc and def2 is a nested procdef
                 (global procedures can be converted into nested procvars)
-             c) if def1 is a nested procedure, then def2 has to be a nested
+             d) if def1 is a nested procedure, then def2 has to be a nested
                 procvar and def1 has to have the po_delphi_nested_cc option
-             d) if def1 is a procvar, def1 and def2 both have to be nested or
+             e) if def1 is a procvar, def1 and def2 both have to be nested or
                 non-nested (we don't allow assignments from non-nested to
                 nested procvars to make sure that we can still implement
                 nested procvars using trampolines -- e.g., this would be
                 necessary for LLVM or CIL as long as they do not have support
                 for Delphi-style frame pointer parameter passing) }
-         if (def1.is_methodpointer<>def2.is_methodpointer) or  { a) }
-            ((def1.is_addressonly<>def2.is_addressonly) and    { b) }
+         if is_block(def2) then                                     { a) }
+           { can't explicitly check against procvars here, because
+             def1 may already be a procvar due to a proc_to_procvar;
+             this is checked in the type conversion node itself -> ok }
+         else if (def1.is_methodpointer<>def2.is_methodpointer) or  { b) }
+            ((def1.is_addressonly<>def2.is_addressonly) and         { c) }
              (is_nested_pd(def1) or
               not is_nested_pd(def2))) or
-            ((def1.typ=procdef) and                            { c) }
+            ((def1.typ=procdef) and                                 { d) }
              is_nested_pd(def1) and
              (not(po_delphi_nested_cc in def1.procoptions) or
               not is_nested_pd(def2))) or
-            ((def1.typ=procvardef) and                         { d) }
+            ((def1.typ=procvardef) and                              { e) }
              (is_nested_pd(def1)<>is_nested_pd(def2))) then
            exit;
          pa_comp:=[cpo_ignoreframepointer];
+         if is_block(def2) then
+           include(pa_comp,cpo_ignorehidden);
          if checkincompatibleuniv then
            include(pa_comp,cpo_warn_incompatible_univ);
          { check return value and options, methodpointer is already checked }

compiler/ncnv.pas

@@ -2015,8 +2015,7 @@ implementation
                 while (source^.nodetype=typeconvn) and
                       (ttypeconvnode(source^).convtype=tc_proc_2_procvar) and
                       (is_void(source^.resultdef) or
-                       ((source^.resultdef.typ=procvardef) and
-                        tprocvardef(source^.resultdef).is_addressonly)) do
+                       (source^.resultdef.typ=procvardef)) do
                   begin
                     { won't skip proc2procvar }
                     source:=actualtargetnode(@ttypeconvnode(source^).left);

compiler/symcreat.pas

@@ -916,6 +916,20 @@ implementation
     end;
 
 
+  procedure implement_block_invoke_procvar(pd: tprocdef);
+    var
+      str: ansistring;
+    begin
+      str:='';
+      str:='begin ';
+      if pd.returndef<>voidtype then
+        str:=str+'result:=';
+      str:=str+'__FPC_BLOCK_INVOKE_PV_TYPE(PFPC_Block_literal_complex_procvar(FPC_Block_Self)^.pv)(';
+      addvisibibleparameters(str,pd);
+      str:=str+') end;';
+      str_parse_method_impl(str,pd,false);
+    end;
+
   procedure add_synthetic_method_implementations_for_st(st: tsymtable);
     var
       i   : longint;
@@ -986,6 +1000,8 @@ implementation
               implement_field_getter(pd);
             tsk_field_setter:
               implement_field_setter(pd);
+            tsk_block_invoke_procvar:
+              implement_block_invoke_procvar(pd);
             else
               internalerror(2011032801);
           end;

tests/test/tblock2.pp

@@ -0,0 +1,51 @@
+{ %target=darwin,iphonesim}
+
+{$mode objfpc}
+{$modeswitch blocks}
+
+type
+  tblock = reference to procedure(j: longint); cdecl;
+
+  tc = class
+    i: longint;
+    procedure callme(j: longint);
+  end;
+
+var
+  b: tblock;
+  c: tc;
+
+procedure tc.callme(j: longint);
+const
+  invocationcount: longint = 0;
+begin
+  writeln('self: ',hexstr(pointer(self)),', i: ',i,', j: ',j);
+  if self<>c then
+    halt(1);
+  if i<>12345 then
+    halt(2);
+  if invocationcount=0 then
+    begin
+      if j<>1 then
+        halt(3)
+    end
+  else if j<>2 then
+    halt(4);
+  inc(invocationcount);
+end;
+
+
+procedure test(b: tblock);
+  begin
+    b(2);
+  end;
+
+begin
+  c:=tc.create;
+  c.i:=12345;
+  b:[email protected];
+  b(1);
+  test(@c.callme);
+  test(b);
+end.
+

tests/test/tblock2a.pp

@@ -0,0 +1,51 @@
+{ %target=darwin,iphonesim}
+
+{$mode delphi}
+{$modeswitch blocks}
+
+type
+  tblock = reference to procedure(j: longint); cdecl;
+
+  tc = class
+    i: longint;
+    procedure callme(j: longint);
+  end;
+
+var
+  b: tblock;
+  p: procedure(j: longint) of object;
+  c: tc;
+
+procedure tc.callme(j: longint);
+const
+  invocationcount: longint = 0;
+begin
+  writeln('self: ',hexstr(pointer(self)),', i: ',i,', j: ',j);
+  if self<>c then
+    halt(1);
+  if i<>12345 then
+    halt(2);
+  if invocationcount=0 then
+    begin
+      if j<>1 then
+        halt(3)
+    end
+  else if j<>2 then
+    halt(4);
+  inc(invocationcount);
+end;
+
+procedure test(b: tblock);
+  begin
+    b(2);
+  end;
+
+begin
+  c:=tc.create;
+  c.i:=12345;
+  b:=c.callme;
+  b(1);
+  test(c.callme);
+  test(b);
+end.
+