From 8111e92e1f36b508d8b52157ffe178e81226302f Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 14 Dec 2019 16:45:38 +0000 Subject: [PATCH] * 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 | 2 ++ compiler/msg/errore.msg | 6 +++- compiler/pdecl.pas | 24 ++++++------- compiler/pdecsub.pas | 11 +++++- compiler/tokens.pas | 2 ++ tests/test/tblock1.pp | 2 +- tests/test/tblock1a.pp | 2 +- tests/test/tblock1c.pp | 2 +- tests/test/tblock2.pp | 2 +- tests/test/tblock2a.pp | 2 +- tests/test/tblock3a.pp | 75 +++++++++++++++++++++++++++++++++++++++++ tests/test/tblock3b.pp | 16 +++++++++ 12 files changed, 126 insertions(+), 20 deletions(-) create mode 100644 tests/test/tblock3a.pp create mode 100644 tests/test/tblock3b.pp diff --git a/.gitattributes b/.gitattributes index 4498e15d05..621c1b4299 100644 --- a/.gitattributes +++ b/.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 diff --git a/compiler/msg/errore.msg b/compiler/msg/errore.msg index a7bc8872d1..a90f34e103 100644 --- a/compiler/msg/errore.msg +++ b/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 diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index 3a4f99466c..872e820cee 100644 --- a/compiler/pdecl.pas +++ b/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; diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index c67ba9a343..c6e1252f49 100644 --- a/compiler/pdecsub.pas +++ b/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]; diff --git a/compiler/tokens.pas b/compiler/tokens.pas index e208e6bbd8..dd6cd2a716 100644 --- a/compiler/tokens.pas +++ b/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), diff --git a/tests/test/tblock1.pp b/tests/test/tblock1.pp index db34e16ed7..e728cb1a75 100644 --- a/tests/test/tblock1.pp +++ b/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 diff --git a/tests/test/tblock1a.pp b/tests/test/tblock1a.pp index 9e24a93435..ae803064ed 100644 --- a/tests/test/tblock1a.pp +++ b/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 diff --git a/tests/test/tblock1c.pp b/tests/test/tblock1c.pp index 2702207591..6be25a374f 100644 --- a/tests/test/tblock1c.pp +++ b/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 diff --git a/tests/test/tblock2.pp b/tests/test/tblock2.pp index 235c237364..fd1ab33df1 100644 --- a/tests/test/tblock2.pp +++ b/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; diff --git a/tests/test/tblock2a.pp b/tests/test/tblock2a.pp index 3f68a33f6e..d1cb951c3c 100644 --- a/tests/test/tblock2a.pp +++ b/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; diff --git a/tests/test/tblock3a.pp b/tests/test/tblock3a.pp new file mode 100644 index 0000000000..c1b9970bfd --- /dev/null +++ b/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. + diff --git a/tests/test/tblock3b.pp b/tests/test/tblock3b.pp new file mode 100644 index 0000000000..b7bb9c9c83 --- /dev/null +++ b/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.