* changed the syntax for block procvars from "xxx is block" to

    "reference to ...; cdecl;". The "reference to ..." syntax is what Delphi
    uses for anonymous function references. The "cdecl;" indicates that this
    is for the C-variant of such references, which is what blocks are

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

compiler/blockutl.pas

@@ -65,7 +65,7 @@ implementation
       { todo: nested functions and Objective-C methods }
       else if not is_nested_pd(pd) and
               not is_objcclass(tdef(pd.owner.defowner)) then
-        result:=trecorddef(search_named_unit_globaltype('BLOCKRTL','FPC_BLOCK_LITERAL_PROCVAR',true).typedef)
+        result:=trecorddef(search_named_unit_globaltype('BLOCKRTL','FPC_BLOCK_LITERAL_COMPLEX_PROCVAR',true).typedef)
       else
         internalerror(2014071304);
     end;

compiler/defutil.pas

@@ -331,6 +331,9 @@ interface
     { returns true of def is a methodpointer }
     function is_methodpointer(def : tdef) : boolean;
 
+    { returns true if def is a C "block" }
+    function is_block(def: tdef): boolean;
+
     {# returns the appropriate int type for pointer arithmetic with the given pointer type.
        When adding or subtracting a number to/from a pointer, this function returns the
        int type to which that number has to be converted, before the operation can be performed.
@@ -1441,6 +1444,12 @@ implementation
       end;
 
 
+    function is_block(def: tdef): boolean;
+      begin
+        result:=(def.typ=procvardef) and (po_is_block in tprocvardef(def).procoptions)
+      end;
+
+
     function get_int_type_for_pointer_arithmetic(p : tdef) : tdef;
       begin
 {$ifdef i8086}

compiler/msg/errore.msg

@@ -1535,7 +1535,7 @@ parser_w_ptr_type_ignored=03338_W_Pointer type "$1" ignored
 %
 # Type Checking
 #
-# 04122 is the last used one
+# 04123 is the last used one
 #
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
@@ -1843,13 +1843,13 @@ type_w_zero_to_nil=04090_W_Converting 0 to NIL
 % Use NIL rather than 0 when initialising a pointer.
 type_e_protocol_type_expected=04091_E_Objective-C protocol type expected, but got "$1"
 % The compiler expected a protocol type name, but found something else.
-type_e_objc_type_unsupported=04092_E_The type "$1" is not supported for interaction with the Objective-C runtime.
-% Objective-C makes extensive use of run time type information (RTTI). This format
+type_e_objc_type_unsupported=04092_E_The type "$1" is not supported for interaction with the Objective-C and the blocks runtime.
+% Objective-C and Blocks make extensive use of run time type information (RTTI). This format
 % is defined by the maintainers of the run time and can therefore not be adapted
 % to all possible Object Pascal types. In particular, types that depend on
 % reference counting by the compiler (such as ansistrings and certain kinds of
 % interfaces) cannot be used as fields of Objective-C classes, cannot be
-% directly passed to Objective-C methods, and cannot be encoded using \var{objc\_encode}.
+% directly passed to Objective-C methods or Blocks, and cannot be encoded using \var{objc\_encode}.
 type_e_class_or_objcclass_type_expected=04093_E_Class or objcclass type expected, but got "$1"
 % It is only possible to create class reference types of \var{class} and \var{objcclass}
 type_e_objcclass_type_expected=04094_E_Objcclass type expected
@@ -1965,6 +1965,13 @@ type_e_procedure_must_be_far=04121_E_Procedure or function must be far in order
 type_w_instance_abstract_class=04122_W_Creating an instance of abstract class "$1"
 % The specified class is declared as \var{abstract} and thus no instance of this class
 % should be created. This is merely a warning for Delphi compatibility.
+type_e_function_reference_kind=04123_E_Subroutine references cannot be declared as "of object" or "is nested", they can always refer to any kind of subroutine
+% Subroutine references can refer to any kind of subroutine and hence do not
+% require specialisation for methods or nested subroutines.
+type_e_anonymous_function_unsupported=04999_E_Function references are not yet supported, only blocks (add "cdecl;" at the end)
+% Remove this error message once Delphi-style anonymous are implemented. It has
+% number 4999 so as not to result in a gap in the error message numbering once
+% it's removed.
 % \end{description}
 #
 # Symtable

compiler/msgidx.inc

@@ -553,6 +553,8 @@ const
   type_e_type_not_allowed_for_type_helper=04120;
   type_e_procedure_must_be_far=04121;
   type_w_instance_abstract_class=04122;
+  type_e_function_reference_kind=04123;
+  type_e_anonymous_function_unsupported=04999;
   sym_e_id_not_found=05000;
   sym_f_internal_error_in_symtablestack=05001;
   sym_e_duplicate_id=05002;
@@ -994,9 +996,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 72030;
+  MsgTxtSize = 72262;
 
   MsgIdxMax : array[1..20] of longint=(
-    26,99,339,123,89,57,126,27,202,64,
+    26,99,339,1000,89,57,126,27,202,64,
     58,20,1,1,1,1,1,1,1,1
   );

compiler/pdecl.pas

@@ -787,6 +787,28 @@ implementation
                            consume(_SEMICOLON);
                          end;
                        parse_var_proc_directives(tsym(newtype));
+                       if po_is_function_ref in tprocvardef(hdef).procoptions then
+                         begin
+                           { these always support everything, no "of object" or
+                             "is_nested" is allowed }
+                           if is_nested_pd(tprocvardef(hdef)) or
+                              is_methodpointer(hdef) then
+                             cgmessage(type_e_function_reference_kind)
+                           else
+                             begin
+                               if (po_hascallingconvention in tprocvardef(hdef).procoptions) and
+                                  (tprocvardef(hdef).proccalloption=pocall_cdecl) 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 }
+                                 cgmessage(type_e_anonymous_function_unsupported);
+                             end
+                         end;
                        handle_calling_convention(tprocvardef(hdef));
                        if try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg) then
                          consume(_SEMICOLON);

compiler/ptype.pas

@@ -73,7 +73,7 @@ implementation
        paramgr,procinfo,
        { symtable }
        symconst,symsym,symtable,symcreat,
-       defutil,defcmp,
+       defutil,defcmp,objcdef,
 {$ifdef jvm}
        jvmdef,
 {$endif}
@@ -1401,7 +1401,6 @@ implementation
             newtype:ttypesym;
             old_current_genericdef,
             old_current_specializedef: tstoreddef;
-            nestedok, blockok,
             old_parse_generic: boolean;
           begin
             old_current_genericdef:=current_genericdef;
@@ -1449,34 +1448,12 @@ implementation
                 consume(_OBJECT);
                 include(pd.procoptions,po_methodpointer);
               end
-            else
-              begin
-                nestedok:=m_nested_procvars in current_settings.modeswitches;
-                blockok:=m_blocks in current_settings.modeswitches;
-                if (nestedok or blockok) and
+            else if (m_nested_procvars in current_settings.modeswitches) and
                     try_to_consume(_IS) then
-                  begin
-                    if nestedok and
-                       try_to_consume(_NESTED) then
-                      begin
-                        pd.parast.symtablelevel:=normal_function_level+1;
-                        pd.check_mark_as_nested;
-                      end
-                    else if blockok and
-                       try_to_consume(_BLOCK) then
-                      begin
-                        include(pd.procoptions,po_is_block);
-                      end
-                    else
-                      begin
-                        if nestedok and blockok then
-                          Message2(scan_f_syn_expected,'Nested/Block',tokeninfo^[token].str)
-                        else if nestedok then
-                          consume(_NESTED)
-                        else
-                          consume(_BLOCK)
-                      end;
-                  end;
+              begin
+                consume(_NESTED);
+                pd.parast.symtablelevel:=normal_function_level+1;
+                pd.check_mark_as_nested;
               end;
             symtablestack.pop(pd.parast);
             tparasymtable(pd.parast).readonly:=false;
@@ -1814,6 +1791,43 @@ implementation
                 jvm_create_procvar_class(name,def);
 {$endif}
               end;
+            _ID:
+              begin
+                case idtoken of
+                  _HELPER:
+                    begin
+                      if hadtypetoken and
+                         { don't allow "type helper" in mode delphi and require modeswitch typehelpers }
+                         ([m_delphi,m_type_helpers]*current_settings.modeswitches=[m_type_helpers]) then
+                        begin
+                          { reset hadtypetoken, so that calling code knows that it should not be handled
+                            as a "unique" type }
+                          hadtypetoken:=false;
+                          consume(_HELPER);
+                          def:=object_dec(odt_helper,name,newsym,genericdef,genericlist,nil,ht_type);
+                        end
+                      else
+                        expr_type
+                    end;
+                  _REFERENCE:
+                    begin
+                      if m_blocks in current_settings.modeswitches then
+                        begin
+                          consume(_REFERENCE);
+                          consume(_TO);
+                          def:=procvar_dec(genericdef,genericlist);
+                          { could be errordef in case of a syntax error }
+                          if assigned(def) and
+                             (def.typ=procvardef) then
+                            include(tprocvardef(def).procoptions,po_is_function_ref);
+                        end
+                      else
+                        expr_type;
+                    end;
+                  else
+                    expr_type;
+                end;
+              end
             else
               if (token=_KLAMMERAFFE) and (m_iso in current_settings.modeswitches) then
                 begin
@@ -1824,19 +1838,7 @@ implementation
                     current_module.checkforwarddefs.add(def);
                 end
               else
-                if hadtypetoken and
-                    { don't allow "type helper" in mode delphi and require modeswitch typehelpers }
-                    ([m_delphi,m_type_helpers]*current_settings.modeswitches=[m_type_helpers]) and
-                    (token=_ID) and (idtoken=_HELPER) then
-                  begin
-                    { reset hadtypetoken, so that calling code knows that it should not be handled
-                      as a "unique" type }
-                    hadtypetoken:=false;
-                    consume(_HELPER);
-                    def:=object_dec(odt_helper,name,newsym,genericdef,genericlist,nil,ht_type);
-                  end
-                else
-                  expr_type;
+                expr_type;
          end;
 
          if def=nil then

compiler/symconst.pas

@@ -355,6 +355,8 @@ type
     po_far,
     { the procedure never returns, this information is usefull for dfa }
     po_noreturn,
+    { procvar is a function reference }
+    po_is_function_ref,
     { procvar is a block (http://en.wikipedia.org/wiki/Blocks_(C_language_extension) ) }
     po_is_block
   );

compiler/symtable.pas

@@ -43,6 +43,7 @@ interface
           init_final_check_done : boolean;
           procedure _needs_init_final(sym:TObject;arg:pointer);
           procedure check_forward(sym:TObject;arg:pointer);
+          procedure check_block_valid(def: TObject;arg:pointer);
           procedure labeldefined(sym:TObject;arg:pointer);
           procedure varsymbolused(sym:TObject;arg:pointer);
           procedure TestPrivate(sym:TObject;arg:pointer);
@@ -360,7 +361,7 @@ implementation
       { global }
       verbose,globals,
       { symtable }
-      symutil,defutil,defcmp,
+      symutil,defutil,defcmp,objcdef,
       { module }
       fmodule,
       { codegen }
@@ -656,6 +657,21 @@ implementation
       end;
 
 
+    procedure tstoredsymtable.check_block_valid(def: TObject; arg: pointer);
+      var
+        founderrordef: tdef;
+      begin
+        { all parameters passed to a block must be handled by the Objective-C
+          runtime }
+        if is_block(tdef(def)) and
+           not objcchecktype(tdef(def),founderrordef) then
+          if assigned(tdef(def).typesym) then
+            MessagePos1(tdef(def).typesym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename)
+          else
+            Message1(type_e_objc_type_unsupported,tprocvardef(def).typename)
+      end;
+
+
     procedure TStoredSymtable.labeldefined(sym:TObject;arg:pointer);
       begin
         if (tsym(sym).typ=labelsym) and
@@ -800,6 +816,9 @@ implementation
     procedure tstoredsymtable.check_forwards;
       begin
          SymList.ForEachCall(@check_forward,nil);
+         { check whether all block definitions contain valid Objective-C types
+           (now that all forward definitions have been resolved) }
+         DefList.ForEachCall(@check_block_valid,nil);
       end;
 
 

compiler/tokens.pas

@@ -150,7 +150,6 @@ type
     _ALIAS,
     _ARRAY,
     _BEGIN,
-    _BLOCK,
     _BREAK,
     _CDECL,
     _CLASS,
@@ -258,6 +257,7 @@ type
     _PROCEDURE,
     _PROTECTED,
     _PUBLISHED,
+    _REFERENCE,
     _SOFTFLOAT,
     _THREADVAR,
     _WRITEONLY,
@@ -469,7 +469,6 @@ const
       (str:'ALIAS'         ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'ARRAY'         ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
       (str:'BEGIN'         ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
-      (str:'BLOCK'         ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'BREAK'         ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'CDECL'         ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'CLASS'         ;special:false;keyword:[m_class];op:NOTOKEN),
@@ -577,6 +576,7 @@ const
       (str:'PROCEDURE'     ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
       (str:'PROTECTED'     ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'PUBLISHED'     ;special:false;keyword:[m_none];op:NOTOKEN),
+      (str:'REFERENCE'     ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'SOFTFLOAT'     ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'THREADVAR'     ;special:false;keyword:alllanguagemodes-[m_iso];op:NOTOKEN),
       (str:'WRITEONLY'     ;special:false;keyword:[m_none];op:NOTOKEN),

compiler/utils/ppuutils/ppudump.pp

@@ -1741,7 +1741,8 @@ const
      (mask:po_auto_raised_visibility; str: 'Visibility raised by compiler'),
      (mask:po_far;             str: 'Far'),
      (mask:po_noreturn;        str: 'No return'),
-     (mask:po_is_block;        str: 'Block')
+     (mask:po_is_function_ref; str: 'Function reference'),
+     (mask:po_is_block;        str: 'C "Block"')
   );
 var
   proctypeoption  : tproctypeoption;

rtl/inc/blockrtl.pp

@@ -88,7 +88,6 @@ interface
         we cannot (yet?) generate on the callee side}
       signature: pchar;
     end;
-    PFPC_Block_descriptor_simple = ^FPC_Block_descriptor_simple;
 
     { descriptor for a simple block (no copy/release) }
     FPC_Block_descriptor_complex = record

tests/test/tblock1.pp

@@ -3,7 +3,7 @@
 {$modeswitch blocks}
 
 type
-  tblock = procedure is block;
+  tblock = reference to procedure; cdecl;
 
 procedure test(b: tblock);
   begin

tests/test/tblock1a.pp

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

tests/test/tblock1c.pp

@@ -3,7 +3,7 @@
 {$modeswitch blocks}
 
 type
-  tblock = function(l: longint): longint is block;
+  tblock = reference to function(l: longint): longint; cdecl;
 
 function test(b: tblock; l: longint): longint;
   begin