paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-13 11:59:19 +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

(cherry picked from commit 61debb1559)
This commit is contained in:
Sven/Sarah Barth 2022-08-18 23:09:01 +02:00
parent 3a399845e4
commit 7c731fc3e6
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

@ -1099,10 +1099,10 @@ uses
{ Build VMT indexes for classes and read hint directives } { Build VMT indexes for classes and read hint directives }
objectdef: objectdef:
begin begin
if replaydepth>current_scanner.replay_stack_depth then if replaydepth<current_scanner.replay_stack_depth then
begin begin
try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg); 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); consume(_SEMICOLON);
end; end;
@ -1114,24 +1114,24 @@ uses
procvardef: procvardef:
begin begin
hintsprocessed:=false; hintsprocessed:=false;
if replaydepth>current_scanner.replay_stack_depth then if replaydepth<current_scanner.replay_stack_depth then
begin begin
if not check_proc_directive(true) then if not check_proc_directive(true) then
begin begin
hintsprocessed:=try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg); 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); consume(_SEMICOLON);
end end
else else
hintsprocessed:=true; hintsprocessed:=true;
end; end;
if replaydepth>current_scanner.replay_stack_depth then if replaydepth<current_scanner.replay_stack_depth then
parse_var_proc_directives(ttypesym(srsym)); parse_var_proc_directives(ttypesym(srsym));
handle_calling_convention(tprocvardef(result),hcc_default_actions_intf); handle_calling_convention(tprocvardef(result),hcc_default_actions_intf);
if not hintsprocessed and (replaydepth>current_scanner.replay_stack_depth) then if not hintsprocessed and (replaydepth<current_scanner.replay_stack_depth) then
begin begin
try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg); 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); consume(_SEMICOLON);
end; end;
end; end;
@ -1157,9 +1157,9 @@ uses
end; end;
else else
{ parse hint directives for records and arrays } { 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); 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); consume(_SEMICOLON);
end; end;
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.