paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-31 18:30:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
"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 -
This commit is contained in:
Jonas Maebe 2014-07-18 09:15:29 +00:00
parent bd09b88a5b
commit c730e16031
15 changed files with 347 additions and 280 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/blockutl.pas
View File

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

9
compiler/defutil.pas
View File

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

15
compiler/msg/errore.msg
View File

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

6
compiler/msgidx.inc
View File

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

450
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

22
compiler/pdecl.pas
View File

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

86
compiler/ptype.pas
View File

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

2
compiler/symconst.pas
View File

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

21
compiler/symtable.pas
View File

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

4
compiler/tokens.pas
View File

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

3
compiler/utils/ppuutils/ppudump.pp
View File

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

1
rtl/inc/blockrtl.pp
View File

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

2
tests/test/tblock1.pp
View File

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

2
tests/test/tblock1a.pp
View File

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

2
tests/test/tblock1c.pp
View File

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