mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 08:09:33 +02:00
+ mre tests for cg testuit
This commit is contained in:
carl
parent
f94cec7ddb
commit
589f06c18f
77
tests/test/cg/tassign1.pp
Normal file
77
tests/test/cg/tassign1.pp
Normal file
@ -0,0 +1,77 @@
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondassign() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{ Tests the sortstring assignment. }
|
||||
{****************************************************************}
|
||||
program tassign1;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
const
|
||||
RESULT_STRING = 'Hello world';
|
||||
|
||||
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
function getc : char;
|
||||
begin
|
||||
getc := 'a';
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
failed : boolean;
|
||||
s: shortstring;
|
||||
c: char;
|
||||
Begin
|
||||
Write('secondassign shortstring node testing...');
|
||||
failed := false;
|
||||
|
||||
{ constant string }
|
||||
s:=RESULT_STRING;
|
||||
if s<>RESULT_STRING then
|
||||
failed := true;
|
||||
{ empty constant string, small optim. }
|
||||
s:='';
|
||||
if s<>'' then
|
||||
failed := true;
|
||||
{ constant character }
|
||||
s:='a';
|
||||
if s<>'a' then
|
||||
failed := true;
|
||||
{ non-constant character }
|
||||
c:='a';
|
||||
s:=c;
|
||||
if s<>'a' then
|
||||
failed := true;
|
||||
|
||||
s:=getc;
|
||||
if s<>'a' then
|
||||
failed := true;
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:43 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
211
tests/test/cg/tassign2.pp
Normal file
211
tests/test/cg/tassign2.pp
Normal file
@ -0,0 +1,211 @@
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondassign() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program tassign2;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$warning Will only work on 32-bit cpu's}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
const
|
||||
RESULT_STRING = 'Hello world';
|
||||
RESULT_S64BIT = -12;
|
||||
RESULT_S32BIT = -124356;
|
||||
RESULT_U32BIT = 654321;
|
||||
RESULT_U8BIT = $55;
|
||||
RESULT_S16BIT = -12124;
|
||||
RESULT_REAL = 12.12;
|
||||
|
||||
{ adjusts the size of the bigrecord }
|
||||
MAX_INDEX = 7;
|
||||
|
||||
type
|
||||
{
|
||||
the size of this record should *at least* be the size
|
||||
of a natural register for the target processor
|
||||
}
|
||||
tbigrecord = record
|
||||
x : cardinal;
|
||||
y : cardinal;
|
||||
z : array[0..MAX_INDEX] of byte;
|
||||
end;
|
||||
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
function getresults64bit: int64;
|
||||
begin
|
||||
getresults64bit := RESULT_S64BIT;
|
||||
end;
|
||||
|
||||
function getresults32bit : longint;
|
||||
begin
|
||||
getresults32bit := RESULT_S32BIT;
|
||||
end;
|
||||
|
||||
function getresultu8bit : byte;
|
||||
begin
|
||||
getresultu8bit := RESULT_U8BIT;
|
||||
end;
|
||||
|
||||
function getresults16bit : smallint;
|
||||
begin
|
||||
getresults16bit := RESULT_S16BIT;
|
||||
end;
|
||||
|
||||
function getresultreal : real;
|
||||
begin
|
||||
getresultreal := RESULT_REAL;
|
||||
end;
|
||||
|
||||
var
|
||||
failed : boolean;
|
||||
s64bit : int64;
|
||||
s32bit : longint;
|
||||
s16bit : smallint;
|
||||
u8bit : byte;
|
||||
boolval : boolean;
|
||||
real_val : real;
|
||||
bigrecord1, bigrecord2 : tbigrecord;
|
||||
i: integer;
|
||||
Begin
|
||||
WriteLn('secondassign node testing.');
|
||||
failed := false;
|
||||
{ possibilities : left : any, right : LOC_REFERENCE, LOC_REGISTER,
|
||||
LOC_FPUREGISTER, LOC_CONSTANT, LOC_JUMP and LOC_FLAGS }
|
||||
Write('left : LOC_REFERENCE, right : LOC_CONSTANT tests..');
|
||||
s64bit := RESULT_S64BIT;
|
||||
if s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
|
||||
s32bit := RESULT_S32BIT;
|
||||
if s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
Write('left : LOC_REFERENCE, right : LOC_REGISTER tests..');
|
||||
failed := false;
|
||||
|
||||
s64bit := getresults64bit;
|
||||
if s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
|
||||
s32bit := getresults32bit;
|
||||
if s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
|
||||
s16bit := getresults16bit;
|
||||
if s16bit <> RESULT_S16BIT then
|
||||
failed := true;
|
||||
|
||||
u8bit := getresultu8bit;
|
||||
if u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
Write('left : LOC_REFERENCE, right : LOC_FPUREGISTER tests..');
|
||||
failed := false;
|
||||
|
||||
real_val := getresultreal;
|
||||
if trunc(real_val) <> trunc(RESULT_REAL) then
|
||||
failed := true;
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
Write('left : LOC_REFERENCE, right : LOC_REFERENCE tests..');
|
||||
failed := false;
|
||||
|
||||
bigrecord1.x := RESULT_U32BIT;
|
||||
bigrecord1.y := RESULT_U32BIT;
|
||||
for i:=0 to MAX_INDEX do
|
||||
bigrecord1.z[i] := RESULT_U8BIT;
|
||||
|
||||
fillchar(bigrecord2, sizeof(bigrecord2),#0);
|
||||
|
||||
bigrecord2 := bigrecord1;
|
||||
|
||||
if bigrecord2.x <> RESULT_U32BIT then
|
||||
failed := true;
|
||||
if bigrecord2.y <> RESULT_U32BIT then
|
||||
failed := true;
|
||||
for i:=0 to MAX_INDEX do
|
||||
begin
|
||||
if bigrecord2.z[i] <> RESULT_U8BIT then
|
||||
begin
|
||||
failed := true;
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
Write('left : LOC_REFERENCE, right : LOC_JUMP tests (32-bit cpus only!)..');
|
||||
{!!!!! This test will only work on 32-bit CPU's probably, on 64-bit CPUs
|
||||
the location should be in LOC_FLAGS
|
||||
}
|
||||
failed := false;
|
||||
|
||||
s64bit := RESULT_S64BIT;
|
||||
boolval := s64bit = RESULT_S64BIT;
|
||||
if boolval = FALSE then
|
||||
failed := true;
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
|
||||
Write('left : LOC_REFERENCE, right : LOC_FLAGS tests..');
|
||||
failed := false;
|
||||
|
||||
s32bit := RESULT_S32BIT;
|
||||
boolval := s32bit = RESULT_S32BIT;
|
||||
if boolval = FALSE then
|
||||
failed := true;
|
||||
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:43 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
193
tests/test/cg/tcnvint4.pp
Normal file
193
tests/test/cg/tcnvint4.pp
Normal file
@ -0,0 +1,193 @@
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondtypeconvert() -> second_int_to_real }
|
||||
{****************************************************************}
|
||||
{ PRE-REQUISITES: secondload() }
|
||||
{ secondassign() }
|
||||
{ secondcalln() }
|
||||
{ secondinline() }
|
||||
{ secondadd() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{****************************************************************}
|
||||
{ REMARKS: Tests integer to real conversion }
|
||||
{ This routine assumes that there is a type conversion }
|
||||
{ from all types to s32bit, u32bit or s64bit before conversion }
|
||||
{ to a real. }
|
||||
{****************************************************************}
|
||||
program tcnvint4;
|
||||
|
||||
{$ifdef VER70}
|
||||
{$define tp}
|
||||
{$endif}
|
||||
|
||||
{$R-}
|
||||
|
||||
{$ifdef tp}
|
||||
type
|
||||
smallint = integer;
|
||||
{$endif}
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
RESULT_S64BIT = 101234;
|
||||
RESULT_S32BIT = -1000000;
|
||||
RESULT_U32BIT = 2000000;
|
||||
RESULT_S16BIT = -12123;
|
||||
RESULT_U16BIT = 12123;
|
||||
RESULT_U8BIT = 247;
|
||||
RESULT_S8BIT = -123;
|
||||
|
||||
|
||||
{$ifndef tp}
|
||||
function gets64bit : int64;
|
||||
begin
|
||||
gets64bit := RESULT_S64BIT;
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
function gets32bit : longint;
|
||||
begin
|
||||
gets32bit := RESULT_S32BIT;
|
||||
end;
|
||||
|
||||
function gets16bit : smallint;
|
||||
begin
|
||||
gets16bit := RESULT_S16BIT;
|
||||
end;
|
||||
|
||||
function gets8bit : shortint;
|
||||
begin
|
||||
gets8bit := RESULT_S8BIT;
|
||||
end;
|
||||
|
||||
function getu8bit : byte;
|
||||
begin
|
||||
getu8bit := RESULT_U8BIT;
|
||||
end;
|
||||
|
||||
function getu16bit : word;
|
||||
begin
|
||||
getu16bit := RESULT_U16BIT;
|
||||
end;
|
||||
|
||||
function getu32bit : longint;
|
||||
begin
|
||||
getu32bit := RESULT_U32BIT;
|
||||
end;
|
||||
|
||||
var
|
||||
s32bit : longint;
|
||||
failed : boolean;
|
||||
s16bit : smallint;
|
||||
s8bit : shortint;
|
||||
u8bit : byte;
|
||||
u16bit : word;
|
||||
{$ifndef tp}
|
||||
s64bit : int64;
|
||||
u32bit : cardinal;
|
||||
{$endif}
|
||||
result_val : real;
|
||||
begin
|
||||
{ left : LOC_REFERENCE }
|
||||
Write('second_int_to_real (left : LOC_REFERENCE)...');
|
||||
s64bit := RESULT_S64BIT;
|
||||
failed := false;
|
||||
result_val := s64bit;
|
||||
if trunc(result_val) <> RESULT_S64BIT then
|
||||
failed:=true;
|
||||
|
||||
s32bit := RESULT_S32BIT;
|
||||
result_val := s32bit;
|
||||
if trunc(result_val) <> RESULT_S32BIT then
|
||||
failed:=true;
|
||||
|
||||
|
||||
u32bit := RESULT_U32BIT;
|
||||
result_val := u32bit;
|
||||
if trunc(result_val) <> RESULT_U32BIT then
|
||||
failed:=true;
|
||||
|
||||
s16bit := RESULT_S16BIT;
|
||||
result_val := s16bit;
|
||||
if trunc(result_val) <> RESULT_S16BIT then
|
||||
failed:=true;
|
||||
|
||||
u16bit := RESULT_U16BIT;
|
||||
result_val := u16bit;
|
||||
if trunc(result_val) <> RESULT_U16BIT then
|
||||
failed:=true;
|
||||
|
||||
|
||||
s8bit := RESULT_S8BIT;
|
||||
result_val := s8bit;
|
||||
if trunc(result_val) <> RESULT_S8BIT then
|
||||
failed:=true;
|
||||
|
||||
u8bit := RESULT_U8BIT;
|
||||
result_val := u8bit;
|
||||
if trunc(result_val) <> RESULT_U8BIT then
|
||||
failed:=true;
|
||||
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
Write('second_int_to_real (left : LOC_REGISTER)...');
|
||||
failed := false;
|
||||
result_val := gets64bit;
|
||||
if trunc(result_val) <> RESULT_S64BIT then
|
||||
failed:=true;
|
||||
|
||||
result_val := gets32bit;
|
||||
if trunc(result_val) <> RESULT_S32BIT then
|
||||
failed:=true;
|
||||
|
||||
|
||||
result_val := getu32bit;
|
||||
if trunc(result_val) <> RESULT_U32BIT then
|
||||
failed:=true;
|
||||
|
||||
result_val := getu8bit;
|
||||
if trunc(result_val) <> RESULT_u8BIT then
|
||||
failed:=true;
|
||||
|
||||
|
||||
result_val := gets8bit;
|
||||
if trunc(result_val) <> RESULT_s8BIT then
|
||||
failed:=true;
|
||||
|
||||
|
||||
result_val := gets16bit;
|
||||
if trunc(result_val) <> RESULT_S16BIT then
|
||||
failed:=true;
|
||||
|
||||
|
||||
result_val := getu16bit;
|
||||
if trunc(result_val) <> RESULT_U16BIT then
|
||||
failed:=true;
|
||||
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:43 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
319
tests/test/cg/tfuncret.pp
Normal file
319
tests/test/cg/tfuncret.pp
Normal file
@ -0,0 +1,319 @@
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondfuncret() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program tfuncret;
|
||||
|
||||
{$ifdef ver70}
|
||||
{$define tp}
|
||||
{$endif}
|
||||
|
||||
const
|
||||
{ adjusts the size of the bigrecord }
|
||||
MAX_INDEX = 7;
|
||||
|
||||
|
||||
RESULT_S64BIT = -12;
|
||||
RESULT_S32BIT = -124356;
|
||||
RESULT_U32BIT = 654321;
|
||||
RESULT_U8BIT = $55;
|
||||
type
|
||||
{
|
||||
the size of this record should *at least* be the size
|
||||
of a natural register for the target processor
|
||||
}
|
||||
tbigrecord = record
|
||||
x : cardinal;
|
||||
y : cardinal;
|
||||
z : array[0..MAX_INDEX] of byte;
|
||||
end;
|
||||
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
{****************************************************************}
|
||||
{ SIMPLE CASE }
|
||||
{****************************************************************}
|
||||
|
||||
function getresult_simple_s64bit: int64;
|
||||
var
|
||||
s64bit : int64;
|
||||
i: integer;
|
||||
begin
|
||||
getresult_simple_s64bit := 0;
|
||||
s64bit:=RESULT_S64BIT;
|
||||
getresult_simple_s64bit := s64bit;
|
||||
end;
|
||||
|
||||
|
||||
function getresult_simple_s32bit: longint;
|
||||
var
|
||||
s32bit : longint;
|
||||
i: longint;
|
||||
begin
|
||||
getresult_simple_s32bit := 0;
|
||||
i:=1;
|
||||
i:=i*RESULT_S32BIT div i;
|
||||
s32bit:=i;
|
||||
getresult_simple_s32bit := s32bit;
|
||||
end;
|
||||
|
||||
|
||||
function getresult_simple_bigrecord : tbigrecord;
|
||||
var
|
||||
localbigrecord : tbigrecord;
|
||||
i: integer;
|
||||
begin
|
||||
localbigrecord.x := RESULT_U32BIT;
|
||||
localbigrecord.y := RESULT_U32BIT;
|
||||
for i:=0 to MAX_INDEX do
|
||||
localbigrecord.z[i] := RESULT_U8BIT;
|
||||
getresult_simple_bigrecord := localbigrecord;
|
||||
end;
|
||||
|
||||
{****************************************************************}
|
||||
{ WITH NESTING }
|
||||
{****************************************************************}
|
||||
|
||||
function getresult_nested_s64bit: int64;
|
||||
|
||||
procedure nested_one;
|
||||
var
|
||||
s64bit : int64;
|
||||
i: longint;
|
||||
begin
|
||||
getresult_nested_s64bit := 0;
|
||||
s64bit:=RESULT_S64BIT;
|
||||
getresult_nested_s64bit := s64bit;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_one;
|
||||
end;
|
||||
|
||||
|
||||
function getresult_nested_s32bit: longint;
|
||||
|
||||
|
||||
procedure nested_one;
|
||||
var
|
||||
s32bit : longint;
|
||||
i: longint;
|
||||
begin
|
||||
getresult_nested_s32bit := 0;
|
||||
i:=1;
|
||||
i:=i*RESULT_S32BIT div i;
|
||||
s32bit:=i;
|
||||
getresult_nested_s32bit := s32bit;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_one;
|
||||
end;
|
||||
|
||||
|
||||
function getresult_nested_bigrecord : tbigrecord;
|
||||
|
||||
procedure nested_one;
|
||||
var
|
||||
localbigrecord : tbigrecord;
|
||||
i: longint;
|
||||
begin
|
||||
localbigrecord.x := RESULT_U32BIT;
|
||||
localbigrecord.y := RESULT_U32BIT;
|
||||
for i:=0 to MAX_INDEX do
|
||||
localbigrecord.z[i] := RESULT_U8BIT;
|
||||
getresult_nested_bigrecord := localbigrecord;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_one;
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************}
|
||||
{ WITH COMPLEX NESTING }
|
||||
{****************************************************************}
|
||||
|
||||
function getresult_nested_complex_s64bit: int64;
|
||||
|
||||
procedure nested_one;
|
||||
var
|
||||
s64bit : int64;
|
||||
i: integer;
|
||||
|
||||
function nested_two: int64;
|
||||
begin
|
||||
nested_two:=0;
|
||||
getresult_nested_complex_s64bit := 0;
|
||||
s64bit:=RESULT_S64BIT;
|
||||
getresult_nested_complex_s64bit := s64bit;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_two;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_one;
|
||||
end;
|
||||
|
||||
|
||||
function getresult_nested_complex_s32bit: longint;
|
||||
|
||||
|
||||
procedure nested_one;
|
||||
var
|
||||
s32bit : longint;
|
||||
i: longint;
|
||||
|
||||
function nested_two: longint;
|
||||
begin
|
||||
nested_two := 0;
|
||||
getresult_nested_complex_s32bit := 0;
|
||||
i:=1;
|
||||
i:=i*RESULT_S32BIT div i;
|
||||
s32bit:=i;
|
||||
getresult_nested_complex_s32bit := s32bit;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_two;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_one;
|
||||
end;
|
||||
|
||||
|
||||
function getresult_nested_complex_bigrecord : tbigrecord;
|
||||
|
||||
procedure nested_one;
|
||||
var
|
||||
localbigrecord : tbigrecord;
|
||||
|
||||
function nested_two : tbigrecord;
|
||||
var
|
||||
i : integer;
|
||||
begin
|
||||
nested_two := localbigrecord;
|
||||
localbigrecord.x := RESULT_U32BIT;
|
||||
localbigrecord.y := RESULT_U32BIT;
|
||||
for i:=0 to MAX_INDEX do
|
||||
localbigrecord.z[i] := RESULT_U8BIT;
|
||||
getresult_nested_complex_bigrecord := localbigrecord;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_two;
|
||||
end;
|
||||
|
||||
begin
|
||||
nested_one;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
failed : boolean;
|
||||
bigrecord : tbigrecord;
|
||||
i: integer;
|
||||
Begin
|
||||
Write('secondfuncret simple case tests...');
|
||||
failed := false;
|
||||
if getresult_simple_s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
if getresult_simple_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
bigrecord := getresult_simple_bigrecord;
|
||||
if bigrecord.x <> RESULT_U32BIT then
|
||||
failed := true;
|
||||
if bigrecord.y <> RESULT_U32BIT then
|
||||
failed := true;
|
||||
for i:=0 to MAX_INDEX do
|
||||
begin
|
||||
if bigrecord.z[i] <> RESULT_U8BIT then
|
||||
begin
|
||||
failed := true;
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
Write('secondfuncret simple nesting case tests...');
|
||||
failed := false;
|
||||
if getresult_nested_s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
if getresult_nested_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
|
||||
bigrecord := getresult_nested_bigrecord;
|
||||
if bigrecord.x <> RESULT_U32BIT then
|
||||
failed := true;
|
||||
if bigrecord.y <> RESULT_U32BIT then
|
||||
failed := true;
|
||||
for i:=0 to MAX_INDEX do
|
||||
begin
|
||||
if bigrecord.z[i] <> RESULT_U8BIT then
|
||||
begin
|
||||
failed := true;
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
Write('secondfuncret complex nesting case tests...');
|
||||
failed := false;
|
||||
if getresult_nested_complex_s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
if getresult_nested_complex_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
|
||||
bigrecord := getresult_nested_complex_bigrecord;
|
||||
if bigrecord.x <> RESULT_U32BIT then
|
||||
failed := true;
|
||||
if bigrecord.y <> RESULT_U32BIT then
|
||||
failed := true;
|
||||
for i:=0 to MAX_INDEX do
|
||||
begin
|
||||
if bigrecord.z[i] <> RESULT_U8BIT then
|
||||
begin
|
||||
failed := true;
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
if failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:43 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
72
tests/test/cg/tloadvmt.pp
Normal file
72
tests/test/cg/tloadvmt.pp
Normal file
@ -0,0 +1,72 @@
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondloadvmt() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program tloadvmt;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
const
|
||||
RESULT_STRING = 'Hello world';
|
||||
|
||||
Type
|
||||
TAObject = class(TObject)
|
||||
a : longint;
|
||||
end;
|
||||
TBObject = Class(TAObject)
|
||||
b : longint;
|
||||
s : shortstring;
|
||||
constructor create(c: longint);
|
||||
function getstring : shortstring;
|
||||
end;
|
||||
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
constructor tbobject.create(c:longint);
|
||||
begin
|
||||
taobject.create;
|
||||
b:=c;
|
||||
s:=RESULT_STRING;
|
||||
end;
|
||||
|
||||
function tbobject.getstring : shortstring;
|
||||
begin
|
||||
getstring := s;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
bobj: TBobject;
|
||||
i: integer;
|
||||
l : longint;
|
||||
Begin
|
||||
i:=$7f;
|
||||
Write('Secondloadvmt test...');
|
||||
bobj:=TBobject.create(i);
|
||||
if bobj.getstring <> RESULT_STRING then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:43 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
64
tests/test/cg/traise1.pp
Normal file
64
tests/test/cg/traise1.pp
Normal file
@ -0,0 +1,64 @@
|
||||
{ %RESULT=217 }
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondraise() }
|
||||
{****************************************************************}
|
||||
{ PRE-REQUISITES: secondload() }
|
||||
{ secondassign() }
|
||||
{ secondtypeconv() }
|
||||
{ secondtryexcept() }
|
||||
{ secondcalln() }
|
||||
{ secondadd() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program traise1;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
Type
|
||||
TAObject = class(TObject)
|
||||
a : longint;
|
||||
end;
|
||||
TBObject = Class(TObject)
|
||||
b : longint;
|
||||
constructor create(c: longint);
|
||||
end;
|
||||
|
||||
|
||||
{ The test cases were taken from the SAL internal architecture manual }
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
constructor tbobject.create(c:longint);
|
||||
begin
|
||||
inherited create;
|
||||
b:=c;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
A: TAObject;
|
||||
Begin
|
||||
A:=TAobject.create;
|
||||
raise A;
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:44 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
61
tests/test/cg/traise2.pp
Normal file
61
tests/test/cg/traise2.pp
Normal file
@ -0,0 +1,61 @@
|
||||
{ %RESULT=217 }
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondraise() }
|
||||
{****************************************************************}
|
||||
{ PRE-REQUISITES: secondload() }
|
||||
{ secondassign() }
|
||||
{ secondtypeconv() }
|
||||
{ secondtryexcept() }
|
||||
{ secondcalln() }
|
||||
{ secondadd() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program traise2;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
Type
|
||||
TAObject = class(TObject)
|
||||
a : longint;
|
||||
end;
|
||||
TBObject = Class(TObject)
|
||||
b : longint;
|
||||
constructor create(c: longint);
|
||||
end;
|
||||
|
||||
|
||||
{ The test cases were taken from the SAL internal architecture manual }
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
constructor tbobject.create(c:longint);
|
||||
begin
|
||||
inherited create;
|
||||
b:=c;
|
||||
end;
|
||||
|
||||
|
||||
Begin
|
||||
raise TAobject.create;
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:44 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
65
tests/test/cg/traise3.pp
Normal file
65
tests/test/cg/traise3.pp
Normal file
@ -0,0 +1,65 @@
|
||||
{ %RESULT=217 }
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondraise() }
|
||||
{****************************************************************}
|
||||
{ PRE-REQUISITES: secondload() }
|
||||
{ secondassign() }
|
||||
{ secondtypeconv() }
|
||||
{ secondtryexcept() }
|
||||
{ secondcalln() }
|
||||
{ secondadd() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program traise3;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
Type
|
||||
TAObject = class(TObject)
|
||||
a : longint;
|
||||
end;
|
||||
TBObject = Class(TObject)
|
||||
b : longint;
|
||||
constructor create(c: longint);
|
||||
end;
|
||||
|
||||
|
||||
{ The test cases were taken from the SAL internal architecture manual }
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
constructor tbobject.create(c:longint);
|
||||
begin
|
||||
inherited create;
|
||||
b:=c;
|
||||
end;
|
||||
|
||||
var
|
||||
bobj: TBobject;
|
||||
i: integer;
|
||||
Begin
|
||||
i:=$7f;
|
||||
bobj := TBobject.create(i);
|
||||
raise bobj;
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:44 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
64
tests/test/cg/traise4.pp
Normal file
64
tests/test/cg/traise4.pp
Normal file
@ -0,0 +1,64 @@
|
||||
{ %RESULT=217 }
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondraise() }
|
||||
{****************************************************************}
|
||||
{ PRE-REQUISITES: secondload() }
|
||||
{ secondassign() }
|
||||
{ secondtypeconv() }
|
||||
{ secondtryexcept() }
|
||||
{ secondcalln() }
|
||||
{ secondadd() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program traise4;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
Type
|
||||
TAObject = class(TObject)
|
||||
a : longint;
|
||||
end;
|
||||
TBObject = Class(TObject)
|
||||
b : longint;
|
||||
constructor create(c: longint);
|
||||
end;
|
||||
|
||||
|
||||
{ The test cases were taken from the SAL internal architecture manual }
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
constructor tbobject.create(c:longint);
|
||||
begin
|
||||
inherited create;
|
||||
b:=c;
|
||||
end;
|
||||
|
||||
var
|
||||
bobj: TBobject;
|
||||
i: integer;
|
||||
Begin
|
||||
i:=$7f;
|
||||
raise TBobject.create(i);
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:44 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
74
tests/test/cg/traise5.pp
Normal file
74
tests/test/cg/traise5.pp
Normal file
@ -0,0 +1,74 @@
|
||||
{ %RESULT=217 }
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondraise() }
|
||||
{****************************************************************}
|
||||
{ PRE-REQUISITES: secondload() }
|
||||
{ secondassign() }
|
||||
{ secondtypeconv() }
|
||||
{ secondtryexcept() }
|
||||
{ secondcalln() }
|
||||
{ secondadd() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program traise5;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
Type
|
||||
TAObject = class(TObject)
|
||||
a : longint;
|
||||
end;
|
||||
TBObject = Class(TObject)
|
||||
b : longint;
|
||||
constructor create(c: longint);
|
||||
end;
|
||||
|
||||
|
||||
{ The test cases were taken from the SAL internal architecture manual }
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
constructor tbobject.create(c:longint);
|
||||
begin
|
||||
inherited create;
|
||||
b:=c;
|
||||
end;
|
||||
|
||||
|
||||
procedure MyRoutine;
|
||||
Begin
|
||||
WriteLn('hello world!');
|
||||
end;
|
||||
|
||||
var
|
||||
bobj: TBobject;
|
||||
i: integer;
|
||||
Begin
|
||||
i:=$7f;
|
||||
{$ifdef ver1_0}
|
||||
raise TBobject.create(i) at longint(@MyRoutine);
|
||||
{$else}
|
||||
raise TBobject.create(i) at @MyRoutine;
|
||||
{$endif}
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:44 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
74
tests/test/cg/traise6.pp
Normal file
74
tests/test/cg/traise6.pp
Normal file
@ -0,0 +1,74 @@
|
||||
{ %RESULT=217 }
|
||||
{****************************************************************}
|
||||
{ CODE GENERATOR TEST PROGRAM }
|
||||
{ By Carl Eric Codere }
|
||||
{****************************************************************}
|
||||
{ NODE TESTED : secondraise() }
|
||||
{****************************************************************}
|
||||
{ PRE-REQUISITES: secondload() }
|
||||
{ secondassign() }
|
||||
{ secondtypeconv() }
|
||||
{ secondtryexcept() }
|
||||
{ secondcalln() }
|
||||
{ secondadd() }
|
||||
{****************************************************************}
|
||||
{ DEFINES: }
|
||||
{ FPC = Target is FreePascal compiler }
|
||||
{****************************************************************}
|
||||
{ REMARKS : Tested with Delphi 3 as reference implementation }
|
||||
{****************************************************************}
|
||||
program traise6;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
Type
|
||||
TAObject = class(TObject)
|
||||
a : longint;
|
||||
end;
|
||||
TBObject = Class(TObject)
|
||||
b : longint;
|
||||
constructor create(c: longint);
|
||||
end;
|
||||
|
||||
|
||||
{ The test cases were taken from the SAL internal architecture manual }
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failure.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
|
||||
constructor tbobject.create(c:longint);
|
||||
begin
|
||||
inherited create;
|
||||
b:=c;
|
||||
end;
|
||||
|
||||
|
||||
procedure MyRoutine;
|
||||
Begin
|
||||
WriteLn('hello world!');
|
||||
end;
|
||||
|
||||
var
|
||||
bobj: TBobject;
|
||||
i: integer;
|
||||
Begin
|
||||
i:=$7f;
|
||||
{$ifdef ver1_0}
|
||||
raise TBobject.create(i) at longint(@MyRoutine);
|
||||
{$else}
|
||||
raise TBobject.create(i) at @MyRoutine,$00000001;
|
||||
{$endif}
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-08-10 08:27:44 carl
|
||||
+ mre tests for cg testuit
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user