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

* more delphi/fpc procvar address tests

Browse Source
This commit is contained in:
pierre 2003-02-17 13:47:46 +00:00
parent a59fbd968d
commit 856d87c173
3 changed files with 86 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
tests/tbs/tb0433.pp
View File

@ -1,7 +1,13 @@
{$ifdef FPC}
{$mode Delphi}
{$endif}
{$APPTYPE CONSOLE}
{$ifdef fpc}
{$mode tp}
{$endif fpc}
function times2(x : longint) : longint;
begin
times2:=2*x;
end;
var
x:function(x:longint):longint;
y:pointer absolute x;
@ -21,4 +27,11 @@ begin
writeln('Absolute Error');
halt(1);
end;
x:=times2;
if (y<>@times2) then
begin
writeln('Absolute Error');
halt(1);
end;
end.

32
tests/tbs/tb0433a.pp Normal file
View File

@ -0,0 +1,32 @@
{$ifdef fpc}
{$mode delphi}
{$endif fpc}
function times2(x : longint) : longint;
begin
times2:=2*x;
end;
var
x:function(x:longint):longint;
y:pointer absolute x;
z,w,v:pointer;
begin
x:=times2;
z:=@x;
w:=addr(x);
v:=@times2;
writeln(longint(y),' ',longint(z),' ',longint(w),' ',longint(v));
if (z<>w) or (z<>v) or (y<>z) then
begin
writeln('Addr Error');
halt(1);
end;
if (y<>@times2) then
begin
writeln('Absolute Error');
halt(1);
end;
end.

37
tests/tbs/tb0433b.pp Normal file
View File

@ -0,0 +1,37 @@
{$ifdef fpc}
{$mode fpc}
{$endif fpc}
function times2(x : longint) : longint;
begin
times2:=2*x;
end;
var
x:function(x:longint):longint;
y:pointer absolute x;
z,w,v:pointer;
begin
z:=@x;
w:=addr(x);
v:=@y;
writeln(longint(y),' ',longint(z),' ',longint(w),' ',longint(v));
if (z<>w) or (z<>v) then
begin
writeln('Addr Error');
halt(1);
end;
if (y<>nil) then
begin
writeln('Absolute Error');
halt(1);
end;
x:=@times2;
if (y<>pointer(@times2)) then
begin
writeln('Absolute Error');
halt(1);
end;
end.