fpc/tests/test/cg/tsubst.pp
svenbarth e8153df7b7 * fix compilation
git-svn-id: trunk@39132 -
2018-05-28 15:16:37 +00:00

773 lines
15 KiB
ObjectPascal

{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{****************************************************************}
{ NODE TESTED : secondsubscriptn(), partial secondload() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{****************************************************************}
{ DEFINES: VERBOSE = Write test information to screen }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS: }
{ }
{ }
{ }
{****************************************************************}
Program tsubst1;
{$mode objfpc}
{$IFNDEF FPC}
type smallint = integer;
{$ENDIF}
const
{ Should be equal to the maximum offset possible in indirect addressing
mode with displacement. (CPU SPECIFIC) }
{$ifdef cpu68k}
{$define use_small}
{$endif}
{$ifdef cpui8086}
{$define use_small}
{$endif}
{$ifdef use_small}
MAX_DISP = 32767;
{$else}
MAX_DISP = 65535;
{$endif}
{ These different alignments are described in the PowerPC ABI
supplement, they should represent most possible cases.
}
type
tlevel1rec = record
c: byte;
end;
tlevel2rec = record
c: byte;
d: byte;
s: word;
n: longint;
end;
tlevel3rec = record
c: byte;
s: word;
end;
tlevel4rec = record
c: byte;
i : int64;
s: word;
end;
tlevel5rec = record
c: byte;
s: word;
j: longint;
end;
tlevel1rec_big = record
fill : array[1..MAX_DISP] of byte;
c: byte;
end;
tlevel2rec_big = record
fill : array[1..MAX_DISP] of byte;
c: byte;
d: byte;
s: word;
n: longint;
end;
tlevel3rec_big = record
fill : array[1..MAX_DISP] of byte;
c: byte;
s: word;
end;
tlevel4rec_big = record
fill : array[1..MAX_DISP] of byte;
c: byte;
i : int64;
s: word;
end;
tlevel5rec_big = record
fill : array[1..MAX_DISP] of byte;
c: byte;
s: word;
j: longint;
end;
{ packed record, for testing misaligned access }
tlevel1rec_packed = packed record
c: byte;
end;
tlevel2rec_packed = packed record
c: byte;
d: byte;
s: word;
n: longint;
end;
tlevel3rec_packed = packed record
c: byte;
s: word;
end;
tlevel4rec_packed = packed record
c: byte;
i : int64;
s: word;
end;
tlevel5rec_packed = packed record
c: byte;
s: word;
j: longint;
end;
tclass1 = class
fill : array[1..MAX_DISP] of byte;
c: byte;
s: word;
j: longint;
end;
tclass2 = class
c: byte;
s: word;
i: int64;
end;
{ test with global variables }
const
RESULT_U8BIT = $55;
RESULT_U16BIT = $500F;
RESULT_S32BIT = $500F0000;
RESULT_S64BIT = $500F0000;
level1rec : tlevel1rec =
(
c: RESULT_U8BIT
);
level2rec : tlevel2rec =
(
c: RESULT_U8BIT;
d: RESULT_U8BIT;
s: RESULT_U16BIT;
n: RESULT_S32BIT;
);
level3rec : tlevel3rec =
(
c: RESULT_U8BIT;
s: RESULT_U16BIT;
);
level4rec : tlevel4rec =
(
c: RESULT_U8BIT;
i : RESULT_S64BIT;
s : RESULT_U16BIT
);
level5rec : tlevel5rec =
(
c: RESULT_U8BIT;
s: RESULT_U16BIT;
j: RESULT_S32BIT;
);
level1rec_packed : tlevel1rec_packed =
(
c: RESULT_U8BIT
);
level2rec_packed : tlevel2rec_packed =
(
c: RESULT_U8BIT;
d: RESULT_U8BIT;
s: RESULT_U16BIT;
n: RESULT_S32BIT;
);
level3rec_packed : tlevel3rec_packed =
(
c: RESULT_U8BIT;
s: RESULT_U16BIT;
);
level4rec_packed : tlevel4rec_packed =
(
c: RESULT_U8BIT;
i : RESULT_S64BIT;
s : RESULT_U16BIT
);
level5rec_packed : tlevel5rec_packed =
(
c: RESULT_U8BIT;
s: RESULT_U16BIT;
j: RESULT_S32BIT;
);
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
var
c,d: byte;
s: word;
n,j: longint;
i: int64;
failed : boolean;
class1 : tclass1;
class2 : tclass2;
procedure clear_globals;
begin
c:=0;
d:=0;
s:=0;
n:=0;
j:=0;
i:=0;
class1:=nil;
class2:=nil
end;
function getclass : tclass1;
begin
getclass := class1;
end;
function getclass2: tclass2;
begin
getclass2 := class2;
end;
{$ifndef cpu68k}
procedure testlocal_big_1;
var
local1rec_big : tlevel1rec_big;
begin
clear_globals;
local1rec_big.c := RESULT_U8BIT;
c:= local1rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
end;
procedure testlocal_big_2;
var
local2rec_big : tlevel2rec_big;
begin
clear_globals;
{ setup values - assign }
local2rec_big.c := RESULT_U8BIT;
local2rec_big.d := RESULT_U8BIT;
local2rec_big.s := RESULT_U16BIT;
local2rec_big.n := RESULT_S32BIT;
{ load values - load }
c:= local2rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
d:= local2rec_big.d;
if d <> RESULT_U8BIT then
failed := true;
s:= local2rec_big.s;
if s <> RESULT_U16BIT then
failed := true;
n:= local2rec_big.n;
if n <> RESULT_S32BIT then
failed := true;
end;
procedure testlocal_big_3;
var
local3rec_big : tlevel3rec_big;
begin
clear_globals;
{ setup values - assign }
local3rec_big.c := RESULT_U8BIT;
local3rec_big.s := RESULT_U16BIT;
c:= local3rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
s:= local3rec_big.s;
if s <> RESULT_U16BIT then
failed := true;
end;
procedure testlocal_big_4;
var
local4rec_big : tlevel4rec_big;
begin
clear_globals;
{ setup values - assign }
local4rec_big.c := RESULT_U8BIT;
local4rec_big.i := RESULT_S64BIT;
local4rec_big.s := RESULT_U16BIT;
c:= local4rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
i:= local4rec_big.i;
if i <> RESULT_S64BIT then
failed := true;
s:= local4rec_big.s;
if s <> RESULT_U16BIT then
failed := true;
end;
procedure testlocal_big_5;
var
local5rec_big : tlevel5rec_big;
begin
clear_globals;
{ setup values - assign }
local5rec_big.c := RESULT_U8BIT;
local5rec_big.s := RESULT_U16BIT;
local5rec_big.j := RESULT_S32BIT;
c:= local5rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
s:= local5rec_big.s;
if s <> RESULT_U16BIT then
failed := true;
j:= local5rec_big.j;
if j <> RESULT_S32BIT then
failed := true;
end;
{$endif}
procedure testlocals;
var
local1rec : tlevel1rec_packed;
local2rec : tlevel2rec_packed;
local3rec : tlevel3rec_packed;
local4rec : tlevel4rec_packed;
local5rec : tlevel5rec_packed;
begin
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
{ normal record access }
Write('Non-Aligned simple local record access (secondvecn())...');
failed := false;
clear_globals;
clear_globals;
local1rec.c := RESULT_U8BIT;
c:= local1rec.c;
if c <> RESULT_U8BIT then
failed := true;
clear_globals;
{ setup values - assign }
local2rec.c := RESULT_U8BIT;
local2rec.d := RESULT_U8BIT;
local2rec.s := RESULT_U16BIT;
local2rec.n := RESULT_S32BIT;
{ load values - load }
c:= local2rec.c;
if c <> RESULT_U8BIT then
failed := true;
d:= local2rec.d;
if d <> RESULT_U8BIT then
failed := true;
s:= local2rec.s;
if s <> RESULT_U16BIT then
failed := true;
n:= local2rec.n;
if n <> RESULT_S32BIT then
failed := true;
clear_globals;
{ setup values - assign }
local3rec.c := RESULT_U8BIT;
local3rec.s := RESULT_U16BIT;
c:= local3rec.c;
if c <> RESULT_U8BIT then
failed := true;
s:= local3rec.s;
if s <> RESULT_U16BIT then
failed := true;
clear_globals;
{ setup values - assign }
local4rec.c := RESULT_U8BIT;
local4rec.i := RESULT_S64BIT;
local4rec.s := RESULT_U16BIT;
c:= local4rec.c;
if c <> RESULT_U8BIT then
failed := true;
i:= local4rec.i;
if i <> RESULT_S64BIT then
failed := true;
s:= local4rec.s;
if s <> RESULT_U16BIT then
failed := true;
clear_globals;
{ setup values - assign }
local5rec.c := RESULT_U8BIT;
local5rec.s := RESULT_U16BIT;
local5rec.j := RESULT_S32BIT;
c:= local5rec.c;
if c <> RESULT_U8BIT then
failed := true;
s:= local5rec.s;
if s <> RESULT_U16BIT then
failed := true;
j:= local5rec.j;
if j <> RESULT_S32BIT then
failed := true;
if failed then
fail
else
WriteLN('Passed!');
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
end;
{---------------------------}
var
level1rec_big : tlevel1rec_big;
level2rec_big : tlevel2rec_big;
level3rec_big : tlevel3rec_big;
level4rec_big : tlevel4rec_big;
level5rec_big : tlevel5rec_big;
begin
{ normal record access }
Write('Aligned simple global record access (secondvecn())...');
failed := false;
clear_globals;
c:= level1rec.c;
if c <> RESULT_U8BIT then
failed := true;
clear_globals;
c:= level2rec.c;
if c <> RESULT_U8BIT then
failed := true;
d:= level2rec.d;
if d <> RESULT_U8BIT then
failed := true;
s:= level2rec.s;
if s <> RESULT_U16BIT then
failed := true;
n:= level2rec.n;
if n <> RESULT_S32BIT then
failed := true;
clear_globals;
c:= level3rec.c;
if c <> RESULT_U8BIT then
failed := true;
s:= level3rec.s;
if s <> RESULT_U16BIT then
failed := true;
clear_globals;
c:= level4rec.c;
if c <> RESULT_U8BIT then
failed := true;
i:= level4rec.i;
if i <> RESULT_S64BIT then
failed := true;
s:= level4rec.s;
if s <> RESULT_U16BIT then
failed := true;
clear_globals;
c:= level5rec.c;
if c <> RESULT_U8BIT then
failed := true;
s:= level5rec.s;
if s <> RESULT_U16BIT then
failed := true;
j:= level5rec.j;
if j <> RESULT_S32BIT then
failed := true;
if failed then
fail
else
WriteLN('Passed!');
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
Write('Non-Aligned simple global record access (secondvecn())...');
clear_globals;
c:= level1rec_packed.c;
if c <> RESULT_U8BIT then
failed := true;
clear_globals;
c:= level2rec_packed.c;
if c <> RESULT_U8BIT then
failed := true;
d:= level2rec_packed.d;
if d <> RESULT_U8BIT then
failed := true;
s:= level2rec_packed.s;
if s <> RESULT_U16BIT then
failed := true;
n:= level2rec_packed.n;
if n <> RESULT_S32BIT then
failed := true;
clear_globals;
c:= level3rec_packed.c;
if c <> RESULT_U8BIT then
failed := true;
s:= level3rec_packed.s;
if s <> RESULT_U16BIT then
failed := true;
clear_globals;
c:= level4rec_packed.c;
if c <> RESULT_U8BIT then
failed := true;
i:= level4rec_packed.i;
if i <> RESULT_S64BIT then
failed := true;
s:= level4rec_packed.s;
if s <> RESULT_U16BIT then
failed := true;
clear_globals;
c:= level5rec_packed.c;
if c <> RESULT_U8BIT then
failed := true;
s:= level5rec_packed.s;
if s <> RESULT_U16BIT then
failed := true;
j:= level5rec_packed.j;
if j <> RESULT_S32BIT then
failed := true;
if failed then
fail
else
WriteLN('Passed!');
Write('Non-Aligned big global record access (secondvecn())...');
clear_globals;
level1rec_big.c := RESULT_U8BIT;
c:= level1rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
clear_globals;
{ setup values - assign }
level2rec_big.c := RESULT_U8BIT;
level2rec_big.d := RESULT_U8BIT;
level2rec_big.s := RESULT_U16BIT;
level2rec_big.n := RESULT_S32BIT;
{ load values - load }
c:= level2rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
d:= level2rec_big.d;
if d <> RESULT_U8BIT then
failed := true;
s:= level2rec_big.s;
if s <> RESULT_U16BIT then
failed := true;
n:= level2rec_big.n;
if n <> RESULT_S32BIT then
failed := true;
clear_globals;
{ setup values - assign }
level3rec_big.c := RESULT_U8BIT;
level3rec_big.s := RESULT_U16BIT;
c:= level3rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
s:= level3rec_big.s;
if s <> RESULT_U16BIT then
failed := true;
clear_globals;
{ setup values - assign }
level4rec_big.c := RESULT_U8BIT;
level4rec_big.i := RESULT_S64BIT;
level4rec_big.s := RESULT_U16BIT;
c:= level4rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
i:= level4rec_big.i;
if i <> RESULT_S64BIT then
failed := true;
s:= level4rec_big.s;
if s <> RESULT_U16BIT then
failed := true;
clear_globals;
{ setup values - assign }
level5rec_big.c := RESULT_U8BIT;
level5rec_big.s := RESULT_U16BIT;
level5rec_big.j := RESULT_S32BIT;
c:= level5rec_big.c;
if c <> RESULT_U8BIT then
failed := true;
s:= level5rec_big.s;
if s <> RESULT_U16BIT then
failed := true;
j:= level5rec_big.j;
if j <> RESULT_S32BIT then
failed := true;
if failed then
fail
else
WriteLN('Passed!');
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
testlocals;
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
{$ifndef cpu68k}
Write('Non-Aligned big local record access (secondvecn())...');
failed := false;
testlocal_big_1;
testlocal_big_2;
testlocal_big_3;
testlocal_big_4;
testlocal_big_5;
if failed then
fail
else
WriteLN('Passed!');
{$endif}
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
Write('Aligned class big field access (secondvecn())...');
clear_globals;
failed := false;
{ LOC_REFERENCE }
class1:=tclass1.create;
class1.c:= RESULT_U8BIT;
class1.j:= RESULT_S32BIT;
class1.s:= RESULT_U16BIT;
c:=class1.c;
if c <> RESULT_U8BIT then
failed := true;
j:=class1.j;
if j <> RESULT_S32BIT then
failed := true;
s:=class1.s;
if s <> RESULT_U16BIT then
failed := true;
class1.destroy;
clear_globals;
{ LOC_REGISTER }
class1:=tclass1.create;
class1.c:= RESULT_U8BIT;
class1.j:= RESULT_S32BIT;
class1.s:= RESULT_U16BIT;
c:=(getclass).c;
if c <> RESULT_U8BIT then
failed := true;
j:=(getclass).j;
if j <> RESULT_S32BIT then
failed := true;
s:=(getclass).s;
if s <> RESULT_U16BIT then
failed := true;
class1.destroy;
if failed then
fail
else
WriteLN('Passed!');
{----------------------------------------------------------------------------}
Write('Aligned class simple field access (secondvecn())...');
clear_globals;
failed := false;
{ LOC_REFERENCE }
class2:=tclass2.create;
class2.c:= RESULT_U8BIT;
class2.i:= RESULT_S64BIT;
class2.s:= RESULT_U16BIT;
c:=class2.c;
if c <> RESULT_U8BIT then
failed := true;
i:=class2.i;
if i <> RESULT_S64BIT then
failed := true;
s:=class2.s;
if s <> RESULT_U16BIT then
failed := true;
class2.destroy;
clear_globals;
{ LOC_REGISTER }
class2:=tclass2.create;
class2.c:= RESULT_U8BIT;
class2.i:= RESULT_S64BIT;
class2.s:= RESULT_U16BIT;
c:=(getclass2).c;
if c <> RESULT_U8BIT then
failed := true;
i:=(getclass2).i;
if i <> RESULT_S64BIT then
failed := true;
s:=(getclass2).s;
if s <> RESULT_U16BIT then
failed := true;
class2.destroy;
if failed then
fail
else
WriteLN('Passed!');
end.