* rework syntax for cblocks: now a cblock directive is required

* additionally implicit calling conventions of cdecl or mwpascal now work as well
* adjusted tests
+ added tests

Note: the generator for packages/univint needs to be fixed, until then building on macOS will be broken

git-svn-id: trunk@43684 -

.gitattributes

@@ -14106,6 +14106,8 @@ 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/tblock3a.pp svneol=native#text/pascal
+tests/test/tblock3b.pp svneol=native#text/pascal
 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/msg/errore.msg

@@ -1611,7 +1611,7 @@ parser_w_enumeration_out_of_range=03353_W_Enumeration symbols can only have valu
 %
 # Type Checking
 #
-# 04124 is the last used one
+# 04126 is the last used one
 #
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
@@ -2047,6 +2047,10 @@ type_e_function_reference_kind=04123_E_Subroutine references cannot be declared
 type_e_seg_procvardef_wrong_memory_model=04124_E_Procedure variables in that memory model do not store segment information
 type_w_empty_constant_range_set=04125_W_The first value of a set constructur range is greater then the second value, so the range describes an empty set.
 % If a set is constructed like this: \var{s:=[9..7];]}, then an empty set is generated. As this is something normally not desired, the compiler warns about it.
+type_e_cblock_callconv=04126_E_C block reference must use CDECL or MWPASCAL calling convention.
+% When declaring a C block reference ensure that it uses either the \var{cdecl} or \var{mwpascal}
+% calling convention either by adding the corresponding function directive or by using the
+% \var{$Calling} compiler directive.
 % \end{description}
 #
 # Symtable

compiler/pdecl.pas

@@ -1053,21 +1053,19 @@ implementation
                              cgmessage(type_e_function_reference_kind)
                            else
                              begin
-                               if (po_hascallingconvention in tprocvardef(hdef).procoptions) and
-                                  (tprocvardef(hdef).proccalloption in [pocall_cdecl,pocall_mwpascal]) then
-                                 begin
-                                   include(tprocvardef(hdef).procoptions,po_is_block);
-                                   { can't check yet whether the parameter types
-                                     are valid for a block, since some of them
-                                     may still be forwarddefs }
-                                 end
-                               else
-                                 { a regular anonymous function type: not yet supported }
-                                 { the }
-                                 Comment(V_Error,'Function references are not yet supported, only C blocks (add "cdecl;" at the end)');
-                             end
+                               { this message is only temporary; once Delphi style anonymous functions
+                                 are supported, this check is no longer required }
+                               if not (po_is_block in tprocvardef(hdef).procoptions) then
+                                 comment(v_error,'Function references are not yet supported, only C blocks (add "cblock;" at the end)');
+                             end;
                          end;
                        handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf);
+                       if po_is_function_ref in tprocvardef(hdef).procoptions then
+                         begin
+                           if (po_is_block in tprocvardef(hdef).procoptions) and
+                              not (tprocvardef(hdef).proccalloption in [pocall_cdecl,pocall_mwpascal]) then
+                             message(type_e_cblock_callconv);
+                         end;
                        if try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg) then
                          consume(_SEMICOLON);
                      end;

compiler/pdecsub.pas

@@ -2388,7 +2388,7 @@ type
    end;
 const
   {Should contain the number of procedure directives we support.}
-  num_proc_directives=52;
+  num_proc_directives=53;
   proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
    (
     (
@@ -2436,6 +2436,15 @@ const
       mutexclpocall : [];
       mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
       mutexclpo     : [po_assembler,po_external]
+    ),(
+      idtok:_CBLOCK;
+      pd_flags : [pd_procvar];
+      handler  : nil;
+      pocall   : pocall_none;
+      pooption : [po_is_block];
+      mutexclpocall : [];
+      mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
+      mutexclpo     : [po_assembler,po_external]
     ),(
       idtok:_CDECL;
       pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];

compiler/tokens.pas

@@ -170,6 +170,7 @@ type
     _WHILE,
     _WRITE,
     _ADDREF,
+    _CBLOCK,
     _DISPID,
     _DIVIDE,
     _DOWNTO,
@@ -511,6 +512,7 @@ const
       (str:'WHILE'         ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
       (str:'WRITE'         ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'ADDREF'        ;special:false;keyword:[m_none];op:NOTOKEN),
+      (str:'CBLOCK'        ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'DISPID'        ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'DIVIDE'        ;special:false;keyword:[m_none];op:NOTOKEN), { delphi operator name }
       (str:'DOWNTO'        ;special:false;keyword:alllanguagemodes;op:NOTOKEN),

tests/test/tblock1.pp

@@ -4,7 +4,7 @@
 {$modeswitch cblocks}
 
 type
-  tblock = reference to procedure; cdecl;
+  tblock = reference to procedure; cdecl; cblock;
 
 procedure test(b: tblock);
   begin

tests/test/tblock1a.pp

@@ -5,7 +5,7 @@
 {$modeswitch cblocks}
 
 type
-  tblock = reference to procedure; cdecl;
+  tblock = reference to procedure; cdecl; cblock;
 
 procedure test(b: tblock);
   begin

tests/test/tblock1c.pp

@@ -4,7 +4,7 @@
 {$modeswitch cblocks}
 
 type
-  tblock = reference to function(l: longint): longint; cdecl;
+  tblock = reference to function(l: longint): longint; cdecl; cblock;
 
 function test(b: tblock; l: longint): longint;
   begin

tests/test/tblock2.pp

@@ -5,7 +5,7 @@
 {$modeswitch cblocks}
 
 type
-  tblock = reference to procedure(j: longint); cdecl;
+  tblock = reference to procedure(j: longint); cdecl; cblock;
 
   tc = class
     i: longint;

tests/test/tblock2a.pp

@@ -5,7 +5,7 @@
 {$modeswitch cblocks}
 
 type
-  tblock = reference to procedure(j: longint); cdecl;
+  tblock = reference to procedure(j: longint); cdecl; cblock;
 
   tc = class
     i: longint;

tests/test/tblock3a.pp

@@ -0,0 +1,75 @@
+{ %target=darwin,iphonesim}
+{ %skipcpu=powerpc,powerpc64 }
+
+program tblock3a;
+
+{$mode objfpc}
+{$modeswitch cblocks}
+
+type
+  {$calling cdecl}
+  tblock1 = reference to procedure(j: longint); cblock;
+
+  {$calling mwpascal}
+  tblock2 = reference to procedure(j : longint); cblock;
+
+  tc = class
+    i: longint;
+    procedure callme(j: longint);
+  end;
+
+var
+  b1: tblock1;
+  b2: tblock2;
+  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);
+  case invocationcount of
+    0:
+      if j<>1 then
+        halt(3);
+    1, 2:
+      if j<>2 then
+        halt(4);
+    3:
+      if j<>3 then
+        halt(5);
+    4, 5:
+      if j<>4 then
+        halt(6);
+  end;
+  inc(invocationcount);
+end;
+
+
+procedure test1(b: tblock1);
+  begin
+    b1(2);
+  end;
+
+procedure test2(b: tblock2);
+  begin
+    b2(4);
+  end;
+
+begin
+  c:=tc.create;
+  c.i:=12345;
+  b1:=@c.callme;
+  b1(1);
+  test1(@c.callme);
+  test1(b1);
+  b2:=@c.callme;
+  b2(3);
+  test2(@c.callme);
+  test2(b2);
+end.
+

tests/test/tblock3b.pp

@@ -0,0 +1,16 @@
+{ %FAIL }
+{ %target=darwin,iphonesim}
+{ %skipcpu=powerpc,powerpc64 }
+
+program tblock3b;
+
+{$mode objfpc}
+{$modeswitch cblocks}
+
+type
+  {$calling stdcall}
+  tblock = reference to procedure; cblock;
+
+begin
+
+end.