From e813a11e85865f629f082f335047e16e3772e0da Mon Sep 17 00:00:00 2001
From: nickysn <nickysn@gmail.com>
Date: Fri, 29 Jun 2018 14:16:35 +0000
Subject: [PATCH] + support TP7-compatible @proc^ (as in FillChar(@proc^,...))

git-svn-id: trunk@39343 -
---
 .gitattributes       |  2 ++
 compiler/pexpr.pas   | 31 +++++++++++++++++++++++++++----
 tests/tbs/tb0646a.pp | 27 +++++++++++++++++++++++++++
 tests/tbs/tb0646b.pp | 27 +++++++++++++++++++++++++++
 4 files changed, 83 insertions(+), 4 deletions(-)
 create mode 100644 tests/tbs/tb0646a.pp
 create mode 100644 tests/tbs/tb0646b.pp

diff --git a/.gitattributes b/.gitattributes
index 6f96ff9557..25d679b374 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -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
diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas
index 11f8a65d00..53e92f277b 100644
--- a/compiler/pexpr.pas
+++ b/compiler/pexpr.pas
@@ -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 :
diff --git a/tests/tbs/tb0646a.pp b/tests/tbs/tb0646a.pp
new file mode 100644
index 0000000000..fb26be4766
--- /dev/null
+++ b/tests/tbs/tb0646a.pp
@@ -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.
diff --git a/tests/tbs/tb0646b.pp b/tests/tbs/tb0646b.pp
new file mode 100644
index 0000000000..7ec6a2ffcb
--- /dev/null
+++ b/tests/tbs/tb0646b.pp
@@ -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.