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

+ support TP7-compatible @proc^ (as in FillChar(@proc^,...))

Browse Source 
git-svn-id: trunk@39343 -
This commit is contained in:
nickysn 2018-06-29 14:16:35 +00:00
parent 5de8f0cf69
commit e813a11e85
4 changed files with 83 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -11551,6 +11551,8 @@ tests/tbs/tb0644.pp svneol=native#text/pascal
tests/tbs/tb0645a.pp svneol=native#text/pascal
tests/tbs/tb0645b.pp svneol=native#text/pascal
tests/tbs/tb0645c.pp svneol=native#text/pascal
tests/tbs/tb0646a.pp svneol=native#text/pascal
tests/tbs/tb0646b.pp svneol=native#text/pascal
tests/tbs/tb205.pp svneol=native#text/plain
tests/tbs/tb610.pp svneol=native#text/pascal
tests/tbs/tb613.pp svneol=native#text/plain

31
compiler/pexpr.pas
View File

@ -2767,7 +2767,7 @@ implementation
wasgenericdummy,
allowspecialize,
isspecialize,
unit_found : boolean;
unit_found, tmpgetaddr: boolean;
dummypos,
tokenpos: tfileposinfo;
spezcontext : tspecializationcontext;
@ -3182,8 +3182,13 @@ implementation
callflags:=[]
else
callflags:=[cnf_unit_specified];
do_proc_call(srsym,srsymtable,nil,
(getaddr and not(token in [_CARET,_POINT,_LECKKLAMMER])),
{ TP7 uglyness: @proc^ is parsed as (@proc)^,
but @notproc^ is parsed as @(notproc^) }
if m_tp_procvar in current_settings.modeswitches then
tmpgetaddr:=getaddr and not(token in [_POINT,_LECKKLAMMER])
else
tmpgetaddr:=getaddr and not(token in [_CARET,_POINT,_LECKKLAMMER]);
do_proc_call(srsym,srsymtable,nil,tmpgetaddr,
again,p1,callflags,spezcontext);
spezcontext:=nil;
end;
@ -3416,6 +3421,11 @@ implementation
sub_expr if necessary }
dopostfix:=not could_be_generic(idstr);
end;
{ TP7 uglyness: @proc^ is parsed as (@proc)^, but @notproc^ is parsed
as @(notproc^) }
if (m_tp_procvar in current_settings.modeswitches) and (token=_CARET) and
getaddr and (p1.nodetype=loadn) and (tloadnode(p1).symtableentry.typ=procsym) then
dopostfix:=false;
{ maybe an additional parameter instead of misusing hadspezialize? }
if dopostfix and not (ef_had_specialize in flags) then
updatefpos:=postfixoperators(p1,again,getaddr);
@ -3770,7 +3780,15 @@ implementation
end
else
p1:=factor(true,[]);
if token in postfixoperator_tokens then
if (token in postfixoperator_tokens) and
{ TP7 uglyness: @proc^ is parsed as (@proc)^, but @notproc^
is parsed as @(notproc^) }
not
(
(m_tp_procvar in current_settings.modeswitches) and
(token=_CARET) and (p1.nodetype=loadn) and (tloadnode(p1).symtableentry.typ=procsym)
)
then
begin
again:=true;
postfixoperators(p1,again,getaddr);
@ -3786,6 +3804,11 @@ implementation
if assigned(getprocvardef) and
(taddrnode(p1).left.nodetype = loadn) then
taddrnode(p1).getprocvardef:=getprocvardef;
if (token in postfixoperator_tokens) then
begin
again:=true;
postfixoperators(p1,again,getaddr);
end;
end;
_LKLAMMER :

27
tests/tbs/tb0646a.pp Normal file
View File

@ -0,0 +1,27 @@
program tb0646a;
{$MODE TP}
procedure TestProc;
begin
Writeln('Hello');
end;
var
arr1,
arr2,
arr3: array [1..10] of Byte;
begin
Move(TestProc, arr1, 10);
Move((@TestProc)^, arr2, 10);
Move(@TestProc^, arr3, 10);
if (CompareByte(arr1, arr2, 10) <> 0) or
(CompareByte(arr2, arr3, 10) <> 0) then
begin
Writeln('Error!');
Halt(1);
end
else
Writeln('Ok!');
end.

27
tests/tbs/tb0646b.pp Normal file
View File

@ -0,0 +1,27 @@
program tb0646b;
{$MODE DELPHI}
procedure TestProc;
begin
Writeln('Hello');
end;
var
arr1,
arr2,
arr3: array [1..10] of Byte;
begin
Move(TestProc, arr1, 10);
Move((@TestProc)^, arr2, 10);
Move(@TestProc^, arr3, 10);
if (CompareByte(arr1, arr2, 10) <> 0) or
(CompareByte(arr2, arr3, 10) <> 0) then
begin
Writeln('Error!');
Halt(1);
end
else
Writeln('Ok!');
end.