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

* fix #39869: correctly check whether the recorded token stream still needs to be parsed (the replay depth of the scanner needs to be *larger* than what it was before starting the playback)

Browse Source 
+ added test
This commit is contained in:
Sven/Sarah Barth 2022-08-18 23:09:01 +02:00
parent a2d7503f71
commit 61debb1559
2 changed files with 76 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
compiler/pgenutil.pas
View File

@ -1995,10 +1995,10 @@ uses
{ Build VMT indexes for classes and read hint directives }
objectdef:
begin
if replaydepth>current_scanner.replay_stack_depth then
if replaydepth<current_scanner.replay_stack_depth then
begin
try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg);
if replaydepth>current_scanner.replay_stack_depth then
if replaydepth<current_scanner.replay_stack_depth then
consume(_SEMICOLON);
end;
@ -2011,18 +2011,18 @@ uses
procvardef:
begin
hintsprocessed:=false;
if replaydepth>current_scanner.replay_stack_depth then
if replaydepth<current_scanner.replay_stack_depth then
begin
if not check_proc_directive(true) then
begin
hintsprocessed:=try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
if replaydepth>current_scanner.replay_stack_depth then
if replaydepth<current_scanner.replay_stack_depth then
consume(_SEMICOLON);
end
else
hintsprocessed:=true;
end;
if replaydepth>current_scanner.replay_stack_depth then
if replaydepth<current_scanner.replay_stack_depth then
parse_proctype_directives(tprocvardef(result));
if po_is_function_ref in tprocvardef(result).procoptions then
adjust_funcref(result,srsym,nil);
@ -2031,10 +2031,10 @@ uses
else
flags:=hcc_default_actions_intf_struct;
handle_calling_convention(result,flags);
if not hintsprocessed and (replaydepth>current_scanner.replay_stack_depth) then
if not hintsprocessed and (replaydepth<current_scanner.replay_stack_depth) then
begin
try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
if replaydepth>current_scanner.replay_stack_depth then
if replaydepth<current_scanner.replay_stack_depth then
consume(_SEMICOLON);
end;
end;
@ -2060,9 +2060,9 @@ uses
end;
else
{ parse hint directives for records and arrays }
if replaydepth>current_scanner.replay_stack_depth then begin
if replaydepth<current_scanner.replay_stack_depth then begin
try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg);
if replaydepth>current_scanner.replay_stack_depth then
if replaydepth<current_scanner.replay_stack_depth then
consume(_SEMICOLON);
end;
end;

67
tests/webtbs/tw39869.pp Normal file
View File

@ -0,0 +1,67 @@
{ %NORUN }
program tw39869;
{$mode objfpc}{$H+}
uses
TypInfo, SysUtils;
{$DEFINE _WORKING}
{$DEFINE NOTWORKING}
type
{$IFDEF NOTWORKING}
generic TCallProcStdCall<T> = procedure(aArg1:T;aArg2:Integer;aArg3:Integer) of object;stdcall;
TGenericCallProcIntegerStdCall = specialize TCallProcStdCall<Integer>;
{$ENDIF}
{ TTest }
generic TGenericTest<T> = class
{$IFDEF WORKING}
type
TCallProcStdCall = procedure(aArg1:T;aArg2:Integer;aArg3:Integer) of object;stdcall;
{$ENDIF}
public
procedure StdCalling(aArg1:T;aArg2:Integer;aArg3:Integer);stdcall;
end;
TIntTest = specialize TGenericTest<Integer>;
{ TTest }
procedure TGenericTest.StdCalling(aArg1:T;aArg2:Integer;aArg3:Integer); stdcall;
begin
WriteLn('Self=0x'+IntToHex(IntPtr(self),SizeOf(self)*2)+
' Arg1='+IntToStr(PtrInt(aArg1))+
' Arg2='+IntToStr(aArg2)+
' Arg3='+IntToStr(aArg3));
end;
var
obj : TIntTest;
{$IFDEF NOTWORKING}
stdCallPtr: TGenericCallProcIntegerStdCall;
{$ENDIF}
{$IFDEF WORKING}
stdCallPtr: specialize TGenericTest<integer>.TCallProcStdCall;
{$ENDIF}
begin
obj := TIntTest.Create;
try
//project1.lpr(51,23) Error:
//Incompatible types:
//got "<procedure variable type of procedure(LongInt;LongInt;LongInt) of object;StdCall>"
//expected "<procedure variable type of procedure(LongInt;LongInt;LongInt) of object;Register>"
stdCallPtr := @obj.StdCalling;
obj.StdCalling(1,2,3);
//call is made with wrong calling convention
stdCallPtr(1,2,3);
//readln;
finally
obj.Free;
end;
end.