paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-28 22:43:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

. remove obsolete tests

Browse Source 
git-svn-id: trunk@21415 -
This commit is contained in:
florian 2012-05-28 14:34:55 +00:00
parent 10023597d2
commit 7cc227be17
7 changed files with 0 additions and 8227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored
View File

@ -9856,7 +9856,6 @@ tests/test/cg/tcalcst5.pp svneol=native#text/plain
tests/test/cg/tcalcst6.pp svneol=native#text/plain
tests/test/cg/tcalcst7.pp svneol=native#text/plain
tests/test/cg/tcalcst8.pp svneol=native#text/plain
tests/test/cg/tcalcst9.pp svneol=native#text/plain
tests/test/cg/tcalext.pp svneol=native#text/plain
tests/test/cg/tcalext3.pp svneol=native#text/plain
tests/test/cg/tcalext4.pp svneol=native#text/plain
@ -9869,7 +9868,6 @@ tests/test/cg/tcalfun4.pp svneol=native#text/plain
tests/test/cg/tcalfun6.pp svneol=native#text/plain
tests/test/cg/tcalfun7.pp svneol=native#text/plain
tests/test/cg/tcalfun8.pp svneol=native#text/plain
tests/test/cg/tcalfun9.pp svneol=native#text/plain
tests/test/cg/tcall1.pp svneol=native#text/plain
tests/test/cg/tcalobj1.pp svneol=native#text/plain
tests/test/cg/tcalobj2.pp svneol=native#text/plain
@ -9877,7 +9875,6 @@ tests/test/cg/tcalobj3.pp svneol=native#text/plain
tests/test/cg/tcalobj4.pp svneol=native#text/plain
tests/test/cg/tcalobj6.pp svneol=native#text/plain
tests/test/cg/tcalobj7.pp svneol=native#text/plain
tests/test/cg/tcalobj8.pp svneol=native#text/plain
tests/test/cg/tcalpext.pp svneol=native#text/plain
tests/test/cg/tcalpvr1.pp svneol=native#text/plain
tests/test/cg/tcalpvr2.pp svneol=native#text/plain
@ -9885,7 +9882,6 @@ tests/test/cg/tcalpvr3.pp svneol=native#text/plain
tests/test/cg/tcalpvr4.pp svneol=native#text/plain
tests/test/cg/tcalpvr6.pp svneol=native#text/plain
tests/test/cg/tcalpvr7.pp svneol=native#text/plain
tests/test/cg/tcalpvr8.pp svneol=native#text/plain
tests/test/cg/tcalval1.pp svneol=native#text/plain
tests/test/cg/tcalval10.pp svneol=native#text/plain
tests/test/cg/tcalval2.pp svneol=native#text/plain
@ -9894,7 +9890,6 @@ tests/test/cg/tcalval4.pp svneol=native#text/plain
tests/test/cg/tcalval5.pp svneol=native#text/plain
tests/test/cg/tcalval7.pp svneol=native#text/plain
tests/test/cg/tcalval8.pp svneol=native#text/plain
tests/test/cg/tcalval9.pp svneol=native#text/plain
tests/test/cg/tcalvar1.pp svneol=native#text/plain
tests/test/cg/tcalvar2.pp svneol=native#text/plain
tests/test/cg/tcalvar3.pp svneol=native#text/plain
@ -9903,7 +9898,6 @@ tests/test/cg/tcalvar5.pp svneol=native#text/plain
tests/test/cg/tcalvar6.pp svneol=native#text/plain
tests/test/cg/tcalvar7.pp svneol=native#text/plain
tests/test/cg/tcalvar8.pp svneol=native#text/plain
tests/test/cg/tcalvar9.pp svneol=native#text/plain
tests/test/cg/tcase.pp svneol=native#text/plain
tests/test/cg/tcase2.pp svneol=native#text/plain
tests/test/cg/tclacla1.pp svneol=native#text/plain

852
tests/test/cg/tcalcst9.pp
View File

@ -1,852 +0,0 @@
{ %maxversion=1.9.4 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondcallparan() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() node }
{ (const parameters with saveregisters }
{ calling convention) }
{****************************************************************}
program tcalcst9;
{$ifdef fpc}
{$mode objfpc}
{$INLINE ON}
{$endif}
{$R+}
{$ifdef VER70}
{$define tp}
{$endif}
{ REAL should map to single or double }
{ so it is not checked, since single }
{ double nodes are checked. }
{ assumes that enumdef is the same as orddef (same storage format) }
const
{ should be defined depending on CPU target }
{$ifdef fpc}
{$ifdef cpu68k}
BIG_INDEX = 8000;
SMALL_INDEX = 13;
{$else}
BIG_INDEX = 33000;
SMALL_INDEX = 13; { value should not be aligned! }
{$endif}
{$else}
BIG_INDEX = 33000;
SMALL_INDEX = 13; { value should not be aligned! }
{$endif}
RESULT_U8BIT = $55;
RESULT_U16BIT = $500F;
RESULT_S32BIT = $500F0000;
RESULT_S64BIT = $500F0000;
RESULT_S32REAL = 1777.12;
RESULT_S64REAL = 3444.24;
RESULT_BOOL8BIT = 1;
RESULT_BOOL16BIT = 1;
RESULT_BOOL32BIT = 1;
RESULT_PCHAR = 'Hello world';
RESULT_BIGSTRING = 'Hello world';
RESULT_SMALLSTRING = 'H';
RESULT_CHAR = 'I';
RESULT_BOOLEAN = TRUE;
type
{$ifndef tp}
tclass1 = class
end;
{$else}
shortstring = string;
{$endif}
tprocedure = procedure;
tsmallrecord =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
b: byte;
w: word;
end;
tlargerecord = packed record
b: array[1..BIG_INDEX] of byte;
end;
tsmallarray = packed array[1..SMALL_INDEX] of byte;
tsmallsetenum =
(A_A,A_B,A_C,A_D);
tsmallset = set of tsmallsetenum;
tlargeset = set of char;
tsmallstring = string[2];
var
global_u8bit : byte;
global_u16bit : word;
global_s32bit : longint;
global_s32real : single;
global_s64real : double;
global_ptr : pchar;
global_proc : tprocedure;
global_bigstring : shortstring;
global_boolean : boolean;
global_char : char;
value_u8bit : byte;
value_u16bit : word;
value_s32bit : longint;
{$ifndef tp}
global_class : tclass1;
global_s64bit : int64;
value_s64bit : int64;
value_class : tclass1;
{$endif}
value_s32real : single;
value_s64real : double;
value_proc : tprocedure;
value_ptr : pchar;
value_smallrec : tsmallrecord;
value_largerec : tlargerecord;
value_smallset : tsmallset;
value_smallstring : tsmallstring;
value_bigstring : shortstring;
value_largeset : tlargeset;
value_smallarray : tsmallarray;
value_boolean : boolean;
value_char : char;
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
procedure clear_globals;
begin
global_u8bit := 0;
global_u16bit := 0;
global_s32bit := 0;
global_s32real := 0.0;
global_s64real := 0.0;
global_ptr := nil;
global_proc := nil;
global_bigstring := '';
global_boolean := false;
global_char := #0;
{$ifndef tp}
global_s64bit := 0;
global_class := nil;
{$endif}
end;
procedure clear_values;
begin
value_u8bit := 0;
value_u16bit := 0;
value_s32bit := 0;
value_s32real := 0.0;
value_s64real := 0.0;
value_proc := nil;
value_ptr := nil;
{$ifndef tp}
value_s64bit := 0;
value_class := nil;
{$endif}
fillchar(value_smallrec, sizeof(value_smallrec), #0);
fillchar(value_largerec, sizeof(value_largerec), #0);
value_smallset := [];
value_smallstring := '';
value_bigstring := '';
value_largeset := [];
fillchar(value_smallarray, sizeof(value_smallarray), #0);
value_boolean := false;
value_char:=#0;
end;
procedure testprocedure;
begin
end;
function getu8bit : byte;
begin
getu8bit:=RESULT_U8BIT;
end;
function getu16bit: word;
begin
getu16bit:=RESULT_U16BIT;
end;
function gets32bit: longint;
begin
gets32bit:=RESULT_S32BIT;
end;
function gets64bit: int64;
begin
gets64bit:=RESULT_S64BIT;
end;
function gets32real: single;
begin
gets32real:=RESULT_S32REAL;
end;
function gets64real: double;
begin
gets64real:=RESULT_S64REAL;
end;
{************************************************************************}
{ CONST PARAMETERS }
{************************************************************************}
procedure proc_const_s32bit(const v : longint);saveregisters;
begin
global_s32bit := v;
end;
{$ifndef tp}
procedure proc_const_s64bit(const v: int64);saveregisters;
begin
global_s64bit:= v;
end;
procedure proc_const_smallarray_const_1(const arr : array of const);saveregisters;
var
i: integer;
begin
for i:=0 to high(arr) do
begin
case arr[i].vtype of
vtInteger : global_u8bit := arr[i].vinteger and $ff;
vtBoolean : global_boolean := arr[i].vboolean;
vtChar : global_char := arr[i].vchar;
vtExtended : global_s64real := arr[i].VExtended^;
vtString : global_bigstring := arr[i].VString^;
vtPointer : ;
vtPChar : global_ptr := arr[i].VPchar;
vtObject : ;
{ vtClass : global_class := (arr[i].VClass) as tclass1;}
vtAnsiString : ;
vtInt64 : global_s64bit := arr[i].vInt64^;
else
RunError(255);
end;
end; {endfor}
end;
procedure proc_const_smallarray_const_2(const arr : array of const);saveregisters;
var
i: integer;
begin
if high(arr)<0 then
global_u8bit := RESULT_U8BIT;
end;
{$endif}
procedure proc_const_smallrecord(const smallrec : tsmallrecord);saveregisters;
begin
if (smallrec.b = RESULT_U8BIT) and (smallrec.w = RESULT_U16BIT) then
global_u8bit := RESULT_U8BIT;
end;
procedure proc_const_largerecord(const largerec : tlargerecord);saveregisters;
begin
if (largerec.b[1] = RESULT_U8BIT) and (largerec.b[2] = RESULT_U8BIT) then
global_u8bit := RESULT_U8BIT;
end;
procedure proc_const_smallset(const smallset : tsmallset);saveregisters;
begin
if A_D in smallset then
global_u8bit := RESULT_U8BIT;
end;
procedure proc_const_largeset(const largeset : tlargeset);saveregisters;
begin
if 'I' in largeset then
global_u8bit := RESULT_U8BIT;
end;
procedure proc_const_smallstring(const s:tsmallstring);saveregisters;
begin
if s = RESULT_SMALLSTRING then
global_u8bit := RESULT_u8BIT;
end;
procedure proc_const_bigstring(const s:shortstring);saveregisters;
begin
if s = RESULT_BIGSTRING then
global_u8bit := RESULT_u8BIT;
end;
procedure proc_const_smallarray(const arr : tsmallarray);saveregisters;
begin
if arr[SMALL_INDEX] = RESULT_U8BIT then
global_u8bit := RESULT_U8BIT;
end;
procedure proc_const_smallarray_open(const arr : array of byte);saveregisters;
begin
{ form 0 to N-1 indexes in open arrays }
if arr[SMALL_INDEX-1] = RESULT_U8BIT then
global_u8bit := RESULT_U8BIT;
end;
procedure proc_const_formaldef_array(const buf);saveregisters;
var
p: pchar;
begin
{ array is indexed from 1 }
p := @buf;
global_u8bit := byte(p[SMALL_INDEX-1]);
end;
{************************************************************************}
{ MIXED CONST PARAMETERS }
{************************************************************************}
procedure proc_const_s32bit_mixed(b1: byte; const v : longint; b2: byte);saveregisters;
begin
global_s32bit := v;
value_u8bit := b2;
end;
{$ifndef tp}
procedure proc_const_s64bit_mixed(b1 : byte; const v: int64; b2: byte);saveregisters;
begin
global_s64bit:= v;
value_u8bit := b2;
end;
procedure proc_const_smallarray_const_1_mixed(b1 : byte; const arr : array of const; b2: byte);saveregisters;
var
i: integer;
begin
for i:=0 to high(arr) do
begin
case arr[i].vtype of
vtInteger : global_u8bit := arr[i].vinteger and $ff;
vtBoolean : global_boolean := arr[i].vboolean;
vtChar : global_char := arr[i].vchar;
vtExtended : global_s64real := arr[i].VExtended^;
vtString : global_bigstring := arr[i].VString^;
vtPointer : ;
vtPChar : global_ptr := arr[i].VPchar;
vtObject : ;
{ vtClass : global_class := (arr[i].VClass) as tclass1;}
vtAnsiString : ;
vtInt64 : global_s64bit := arr[i].vInt64^;
else
RunError(255);
end;
end; {endfor}
value_u8bit := b2;
end;
procedure proc_const_smallarray_const_2_mixed(b1: byte; const arr : array of const; b2: byte);saveregisters;
var
i: integer;
begin
if high(arr)<0 then
global_u8bit := RESULT_U8BIT;
value_u8bit := b2;
end;
{$endif}
procedure proc_const_smallrecord_mixed(b1 : byte; const smallrec : tsmallrecord; b2: byte);saveregisters;
begin
if (smallrec.b = RESULT_U8BIT) and (smallrec.w = RESULT_U16BIT) then
global_u8bit := RESULT_U8BIT;
value_u8bit := b2;
end;
procedure proc_const_largerecord_mixed(b1: byte; const largerec : tlargerecord; b2: byte);saveregisters;
begin
if (largerec.b[1] = RESULT_U8BIT) and (largerec.b[2] = RESULT_U8BIT) then
global_u8bit := RESULT_U8BIT;
value_u8bit := b2;
end;
procedure proc_const_smallset_mixed(b1: byte; const smallset : tsmallset; b2: byte);saveregisters;
begin
if A_D in smallset then
global_u8bit := RESULT_U8BIT;
value_u8bit := b2;
end;
procedure proc_const_largeset_mixed(b1: byte; const largeset : tlargeset; b2: byte);saveregisters;
begin
if 'I' in largeset then
global_u8bit := RESULT_U8BIT;
value_u8bit := b2;
end;
procedure proc_const_smallstring_mixed(b1: byte; const s:tsmallstring; b2: byte);saveregisters;
begin
if s = RESULT_SMALLSTRING then
global_u8bit := RESULT_u8BIT;
value_u8bit := b2;
end;
procedure proc_const_bigstring_mixed(b1: byte; const s:shortstring; b2: byte);saveregisters;
begin
if s = RESULT_BIGSTRING then
global_u8bit := RESULT_u8BIT;
value_u8bit := b2;
end;
procedure proc_const_smallarray_mixed(b1: byte; const arr : tsmallarray; b2: byte);saveregisters;
begin
if arr[SMALL_INDEX] = RESULT_U8BIT then
global_u8bit := RESULT_U8BIT;
value_u8bit := b2;
end;
procedure proc_const_smallarray_open_mixed(b1: byte; const arr : array of byte; b2: byte);saveregisters;
begin
{ form 0 to N-1 indexes in open arrays }
if arr[high(arr)] = RESULT_U8BIT then
global_u8bit := RESULT_U8BIT;
value_u8bit := b2;
end;
procedure proc_const_formaldef_array_mixed(b1: byte; const buf; b2: byte);saveregisters;
var
p: pchar;
begin
{ array is indexed from 1 }
p := @buf;
global_u8bit := byte(p[SMALL_INDEX-1]);
value_u8bit := b2;
end;
var
failed: boolean;
pp : ^pchar;
begin
{***************************** NORMAL TESTS *******************************}
write('Const parameter test (src : LOC_REGISTER (orddef)))...');
clear_globals;
clear_values;
failed:=false;
proc_const_s32bit(gets32bit);
if global_s32bit <> RESULT_S32BIT then
failed:=true;
{$ifndef tp}
proc_const_s64bit(gets64bit);
if global_s64bit <> RESULT_S64BIT then
failed:=true;
{$endif}
if failed then
fail
else
WriteLn('Passed!');
write('Const parameter test (src : LOC_REFERENCE (recorddef)))...');
clear_globals;
clear_values;
failed := false;
value_smallrec.b := RESULT_U8BIT;
value_smallrec.w := RESULT_U16BIT;
proc_const_smallrecord(value_smallrec);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
fillchar(value_largerec,sizeof(value_largerec),RESULT_U8BIT);
proc_const_largerecord(value_largerec);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('const parameter test (src : LOC_REFERENCE (setdef)))...');
clear_globals;
clear_values;
failed := false;
value_smallset := [A_A,A_D];
proc_const_smallset(value_smallset);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_largeset := ['I'];
proc_const_largeset(value_largeset);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('const parameter test (src : LOC_REFERENCE (stringdef)))...');
clear_globals;
clear_values;
failed := false;
value_smallstring := RESULT_SMALLSTRING;
proc_const_smallstring(value_smallstring);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_bigstring := RESULT_BIGSTRING;
proc_const_bigstring(value_bigstring);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Const parameter test (src : LOC_REFERENCE (formaldef)))...');
clear_globals;
clear_values;
failed:=false;
value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
proc_const_formaldef_array(value_smallarray);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Const parameter test (src : LOC_REFERENCE (arraydef)))...');
clear_globals;
clear_values;
failed:=false;
value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
proc_const_smallarray(value_smallarray);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
proc_const_smallarray_open(value_smallarray);
if global_u8bit <> RESULT_U8BIT then
failed := true;
{$ifndef tp}
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
value_ptr := RESULT_PCHAR;
value_s64bit := RESULT_S64BIT;
value_smallstring := RESULT_SMALLSTRING;
value_class := tclass1.create;
value_boolean := RESULT_BOOLEAN;
value_char := RESULT_CHAR;
value_s64real:=RESULT_S64REAL;
proc_const_smallarray_const_1([value_u8bit,value_ptr,value_s64bit,value_char,value_smallstring,value_s64real,
value_boolean,value_class]);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_char <> RESULT_CHAR then
failed := true;
if global_boolean <> RESULT_BOOLEAN then
failed:=true;
if trunc(global_s64real) <> trunc(RESULT_S64REAL) then
failed := true;
if global_bigstring <> RESULT_SMALLSTRING then
failed := true;
if global_ptr <> value_ptr then
failed := true;
{ if value_class <> global_class then
failed := true;!!!!!!!!!!!!!!!!!!!!}
if global_s64bit <> RESULT_S64BIT then
failed := true;
if assigned(value_class) then
value_class.destroy;
global_u8bit := 0;
proc_const_smallarray_const_2([]);
if global_u8bit <> RESULT_U8BIT then
failed := true;
{$endif}
if failed then
fail
else
WriteLn('Passed!');
{***************************** MIXED TESTS *******************************}
write('Mixed const parameter test (src : LOC_REGISTER (orddef)))...');
clear_globals;
clear_values;
failed:=false;
proc_const_s32bit_mixed(RESULT_U8BIT,gets32bit,RESULT_U8BIT);
if global_s32bit <> RESULT_S32BIT then
failed:=true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
{$ifndef tp}
proc_const_s64bit_mixed(RESULT_U8BIT,gets64bit,RESULT_U8BIT);
if global_s64bit <> RESULT_S64BIT then
failed:=true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
{$endif}
if failed then
fail
else
WriteLn('Passed!');
write('Mixed const parameter test (src : LOC_REFERENCE (recorddef)))...');
clear_globals;
clear_values;
failed := false;
value_smallrec.b := RESULT_U8BIT;
value_smallrec.w := RESULT_U16BIT;
proc_const_smallrecord_mixed(RESULT_U8BIT,value_smallrec,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
fillchar(value_largerec,sizeof(value_largerec),RESULT_U8BIT);
proc_const_largerecord_mixed(RESULT_U8BIT,value_largerec,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Mixed const parameter test (src : LOC_REFERENCE (setdef)))...');
clear_globals;
clear_values;
failed := false;
value_smallset := [A_A,A_D];
proc_const_smallset_mixed(RESULT_U8BIT,value_smallset,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_largeset := ['I'];
proc_const_largeset_mixed(RESULT_U8BIT,value_largeset,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Mixed const parameter test (src : LOC_REFERENCE (stringdef)))...');
clear_globals;
clear_values;
failed := false;
value_smallstring := RESULT_SMALLSTRING;
proc_const_smallstring_mixed(RESULT_U8BIT,value_smallstring,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_bigstring := RESULT_BIGSTRING;
proc_const_bigstring_mixed(RESULT_U8BIT,value_bigstring,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Mixed const parameter test (src : LOC_REFERENCE (formaldef)))...');
clear_globals;
clear_values;
failed:=false;
value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
proc_const_formaldef_array_mixed(RESULT_U8BIT,value_smallarray,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Mixed const parameter test (src : LOC_REFERENCE (arraydef)))...');
clear_globals;
clear_values;
failed:=false;
value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
proc_const_smallarray_mixed(RESULT_U8BIt,value_smallarray,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
proc_const_smallarray_open_mixed(RESULT_U8BIT,value_smallarray,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
{$ifndef tp}
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
value_ptr := RESULT_PCHAR;
value_s64bit := RESULT_S64BIT;
value_smallstring := RESULT_SMALLSTRING;
value_class := tclass1.create;
value_boolean := RESULT_BOOLEAN;
value_char := RESULT_CHAR;
value_s64real:=RESULT_S64REAL;
proc_const_smallarray_const_1_mixed(RESULT_U8BIT, [value_u8bit,value_ptr,value_s64bit,value_char,value_smallstring,
value_s64real,value_boolean,value_class],RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_char <> RESULT_CHAR then
failed := true;
if global_boolean <> RESULT_BOOLEAN then
failed:=true;
if trunc(global_s64real) <> trunc(RESULT_S64REAL) then
failed := true;
if global_bigstring <> RESULT_SMALLSTRING then
failed := true;
if global_ptr <> value_ptr then
failed := true;
{ if value_class <> global_class then
failed := true;!!!!!!!!!!!!!!!!!!!!}
if global_s64bit <> RESULT_S64BIT then
failed := true;
if assigned(value_class) then
value_class.destroy;
if value_u8bit <> RESULT_U8BIT then
failed := true;
global_u8bit := 0;
proc_const_smallarray_const_2_mixed(RESULT_U8BIT,[],RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
{$endif}
if failed then
fail
else
WriteLn('Passed!');
end.

1430
tests/test/cg/tcalfun9.pp
View File

File diff suppressed because it is too large Load Diff

3294
tests/test/cg/tcalobj8.pp
View File

File diff suppressed because it is too large Load Diff

527
tests/test/cg/tcalpvr8.pp
View File

@ -1,527 +0,0 @@
{ %maxversion=1.9.4 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{****************************************************************}
{ NODE TESTED : secondcalln() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondcalln() }
{ secondadd() }
{ secondtypeconv() }
{****************************************************************}
{ DEFINES: }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() , it }
{ verifies procedural variables for saveregisters }
{ calling conventions. }
{****************************************************************}
program tcalpvr3;
{$MODE OBJFPC}
{$R+}
const
RESULT_U8BIT = $55;
RESULT_U16BIT = $500F;
RESULT_S32BIT = $500F0000;
RESULT_S64BIT = -12000;
type
troutine = procedure (x: longint; y: byte);saveregisters;
troutineresult = function (x: longint; y: byte): int64;saveregisters;
tsimpleobject = object
constructor init;
procedure test_normal(x: byte);saveregisters;
procedure test_static(x: byte);static;saveregisters;
procedure test_virtual(x: byte);virtual;saveregisters;
end;
tsimpleclass = class
constructor create;
procedure test_normal(x: byte);saveregisters;
class procedure test_static(x: byte);saveregisters;
procedure test_virtual(x: byte);virtual;saveregisters;
end;
tobjectmethod = procedure (x: byte) of object ;saveregisters;
tclassmethod = procedure (x: byte) of object;saveregisters;
var
proc : troutine;
func : troutineresult;
obj_method : tobjectmethod;
cla_method : tclassmethod;
global_s32bit : longint;
global_s64bit : int64;
global_u8bit : byte;
value_s32bit : longint;
value_u8bit : byte;
obj : tsimpleobject;
cla : tsimpleclass;
procedure fail;
begin
WriteLn('Failed!');
halt(1);
end;
procedure clear_globals;
begin
global_s32bit := 0;
global_u8bit := 0;
global_s64bit := 0;
end;
procedure clear_values;
begin
value_s32bit := 0;
value_u8bit := 0;
end;
procedure testroutine(x: longint; y: byte);saveregisters;
begin
global_s32bit := x;
global_u8bit := y;
end;
function testroutineresult(x: longint; y: byte): int64;saveregisters;
begin
global_s32bit := x;
global_u8bit := y;
testroutineresult := RESULT_S64BIT;
end;
function getroutine: troutine;
begin
getroutine:=proc;
end;
function getroutineresult : troutineresult;
begin
getroutineresult := func;
end;
{ IMPOSSIBLE TO DO CURRENTLY !
function get_object_method_static : tnormalmethod;
begin
get_object_method_static := @obj.test_static;
end;
}
{ objects access }
function get_object_method_normal : tobjectmethod;
begin
get_object_method_normal := @obj.test_normal;
end;
function get_object_type_method_virtual : tobjectmethod;
begin
get_object_type_method_virtual := @obj.test_virtual;
end;
function get_object_method_virtual : tobjectmethod;
begin
get_object_method_virtual := @obj.test_virtual;
end;
{
HOW CAN WE GET THIS ADDRESS???
function get_class_method_static_self : tclassmethodself;
begin
get_class_method_static_self := @cla.test_static_self;
end;
}
function get_class_method_normal : tclassmethod;
begin
get_class_method_normal := @cla.test_normal;
end;
{
function get_class_method_static : tclassmethod;
begin
get_class_method_static := @cla.test_static;
end;}
function get_class_method_virtual : tclassmethod;
begin
get_class_method_virtual := @cla.test_virtual;
end;
{****************************************************************************************************}
constructor tsimpleobject.init;
begin
end;
procedure tsimpleobject.test_normal(x: byte);saveregisters;
begin
global_u8bit := x;
end;
procedure tsimpleobject.test_static(x: byte);saveregisters;
begin
global_u8bit := x;
end;
procedure tsimpleobject.test_virtual(x: byte);saveregisters;
begin
global_u8bit := x;
end;
{****************************************************************************************************}
constructor tsimpleclass.create;
begin
inherited create;
end;
procedure tsimpleclass. test_normal(x: byte);saveregisters;
begin
global_u8bit := x;
end;
class procedure tsimpleclass.test_static(x: byte);saveregisters;
begin
global_u8bit := x;
end;
procedure tsimpleclass.test_virtual(x: byte);saveregisters;
begin
global_u8bit := x;
end;
var
failed : boolean;
Begin
{ setup variables }
proc := @testroutine;
func := @testroutineresult;
obj.init;
cla:=tsimpleclass.create;
{****************************************************************************************************}
Write('Testing procedure variable call (LOC_REGISTER)..');
clear_globals;
clear_values;
failed := false;
{ parameters in LOC_CONSTANT, routine address in LOC_REGISTER }
troutine(getroutine)(RESULT_S32BIT,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_s32bit <> RESULT_S32BIT then
failed := true;
clear_globals;
clear_values;
{ parameters in LOC_REFERENCE,routine address in LOC_REGISTER }
value_s32bit := RESULT_S32BIT;
value_u8bit := RESULT_U8BIT;
troutine(getroutine)(value_s32bit , value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_s32bit <> RESULT_S32BIT then
failed := true;
If failed then
fail
else
WriteLn('Passed!');
Write('Testing procedure variable call (LOC_REFERENCE)..');
clear_globals;
clear_values;
failed := false;
{ parameters in LOC_CONSTANT, routine address in LOC_REGISTER }
proc(RESULT_S32BIT,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_s32bit <> RESULT_S32BIT then
failed := true;
clear_globals;
clear_values;
{ parameters in LOC_REFERENCE,routine address in LOC_REGISTER }
value_s32bit := RESULT_S32BIT;
value_u8bit := RESULT_U8BIT;
proc(value_s32bit , value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_s32bit <> RESULT_S32BIT then
failed := true;
If failed then
fail
else
WriteLn('Passed!');
{****************************************************************************************************}
Write('Testing function variable call (LOC_REGISTER)..');
clear_globals;
clear_values;
failed := false;
{ parameters in LOC_CONSTANT, routine address in LOC_REGISTER }
global_s64bit := troutineresult(getroutineresult)(RESULT_S32BIT,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_s32bit <> RESULT_S32BIT then
failed := true;
if global_s64bit <> RESULT_S64BIT then
failed := true;
clear_globals;
clear_values;
{ parameters in LOC_REFERENCE,routine address in LOC_REGISTER }
value_s32bit := RESULT_S32BIT;
value_u8bit := RESULT_U8BIT;
global_s64bit := troutineresult(getroutineresult)(value_s32bit , value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_s32bit <> RESULT_S32BIT then
failed := true;
if global_s64bit <> RESULT_S64BIT then
failed := true;
If failed then
fail
else
WriteLn('Passed!');
Write('Testing function variable call (LOC_REFERENCE)..');
clear_globals;
clear_values;
failed := false;
{ parameters in LOC_CONSTANT, routine address in LOC_REGISTER }
global_s64bit := func(RESULT_S32BIT,RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_s32bit <> RESULT_S32BIT then
failed := true;
if global_s64bit <> RESULT_S64BIT then
failed := true;
clear_globals;
clear_values;
{ parameters in LOC_REFERENCE,routine address in LOC_REGISTER }
value_s32bit := RESULT_S32BIT;
value_u8bit := RESULT_U8BIT;
global_s64bit := func(value_s32bit , value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_s32bit <> RESULT_S32BIT then
failed := true;
if global_s64bit <> RESULT_S64BIT then
failed := true;
If failed then
fail
else
WriteLn('Passed!');
{****************************************************************************************************}
Write('Testing object method variable call (LOC_REGISTER) ..');
clear_globals;
clear_values;
failed := false;
tobjectmethod(get_object_method_normal)(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
tobjectmethod(get_object_type_method_virtual)(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
tobjectmethod(get_object_method_virtual)(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
tobjectmethod(get_object_method_normal)(value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
tobjectmethod(get_object_type_method_virtual)(value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
tobjectmethod(get_object_method_virtual)(value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
If failed then
fail
else
WriteLn('Passed!');
Write('Testing object method variable call (LOC_REFERENCE) ..');
clear_globals;
clear_values;
failed := false;
obj_method:=@obj.test_normal;
obj_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
obj_method:=@obj.test_virtual;
obj_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
obj_method:=@obj.test_virtual;
obj_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
obj_method:=@obj.test_normal;
obj_method(value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
obj_method:=@obj.test_virtual;
obj_method(value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
obj_method:=@obj.test_normal;
obj_method(value_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed := true;
If failed then
fail
else
WriteLn('Passed!');
{****************************************************************************************************}
Write('Testing class method variable call (LOC_REGISTER) ..');
clear_globals;
clear_values;
failed := false;
tclassmethod(get_class_method_normal)(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
tclassmethod(get_class_method_virtual)(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
If failed then
fail
else
WriteLn('Passed!');
Write('Testing class method variable call (LOC_REFERENCE)...');
clear_globals;
clear_values;
failed := false;
cla_method := @cla.test_normal;
cla_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
cla_method := @cla.test_virtual;
cla_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
cla_method := @cla.test_virtual;
cla_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
{ cla_method := @cla.test_static;
cla_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;}
clear_globals;
clear_values;
{ cla_method := @cla.test_static;
cla_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;}
If failed then
fail
else
WriteLn('Passed!');
end.

1294
tests/test/cg/tcalval9.pp
View File

File diff suppressed because it is too large Load Diff

824
tests/test/cg/tcalvar9.pp
View File

@ -1,824 +0,0 @@
{ %maxversion=1.9.4 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondcallparan() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() node }
{ (var parameters with saveregs calling convention) }
{****************************************************************}
program tcalvar9;
{$ifdef fpc}
{$mode objfpc}
{$INLINE ON}
{$endif}
{$R+}
{$P-}
{$V+}
{$ifdef VER70}
{$define tp}
{$endif}
{ REAL should map to single or double }
{ so it is not checked, since single }
{ double nodes are checked. }
{ assumes that enumdef is the same as orddef (same storage format) }
const
{ should be defined depending on CPU target }
{$ifdef fpc}
{$ifdef cpu68k}
BIG_INDEX = 8000;
SMALL_INDEX = 13;
{$else}
BIG_INDEX = 33000;
SMALL_INDEX = 13; { value should not be aligned! }
{$endif}
{$else}
BIG_INDEX = 33000;
SMALL_INDEX = 13; { value should not be aligned! }
{$endif}
RESULT_U8BIT = $55;
RESULT_U16BIT = $500F;
RESULT_S32BIT = $500F0000;
RESULT_S64BIT = $500F0000;
RESULT_S32REAL = 1777.12;
RESULT_S64REAL = 3444.24;
RESULT_BOOL8BIT = 1;
RESULT_BOOL16BIT = 1;
RESULT_BOOL32BIT = 1;
RESULT_PCHAR = 'Hello world';
RESULT_BIGSTRING = 'Hello world';
RESULT_SMALLSTRING = 'H';
RESULT_CHAR = 'I';
RESULT_BOOLEAN = TRUE;
type
{$ifdef fpc}
pbytearr=^byte;
{$else}
pbytearr=^tbytearr;
tbytearr=array[0..$fffffff] of byte;
{$endif}
tclass1 = class
end;
tprocedure = procedure;
tsmallrecord =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
b: byte;
w: word;
end;
tlargerecord = packed record
b: array[1..BIG_INDEX] of byte;
end;
tsmallarray = packed array[1..SMALL_INDEX] of byte;
tsmallsetenum =
(A_A,A_B,A_C,A_D);
tsmallset = set of tsmallsetenum;
tlargeset = set of char;
tsmallstring = string[2];
var
global_u8bit : byte;
global_u16bit : word;
global_s32bit : longint;
global_s64bit : int64;
global_s32real : single;
global_s64real : double;
global_ptr : pchar;
global_proc : tprocedure;
global_class : tclass1;
global_bigstring : shortstring;
global_boolean : boolean;
global_char : char;
value_u8bit : byte;
value_u16bit : word;
value_s32bit : longint;
value_s64bit : int64;
value_s32real : single;
value_s64real : double;
value_proc : tprocedure;
value_ptr : pchar;
value_class : tclass1;
value_smallrec : tsmallrecord;
value_largerec : tlargerecord;
value_smallset : tsmallset;
value_smallstring : tsmallstring;
value_bigstring : shortstring;
value_largeset : tlargeset;
value_smallarray : tsmallarray;
value_boolean : boolean;
value_char : char;
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
procedure clear_globals;
begin
global_u8bit := 0;
global_u16bit := 0;
global_s32bit := 0;
global_s64bit := 0;
global_s32real := 0.0;
global_s64real := 0.0;
global_ptr := nil;
global_proc := nil;
global_class := nil;
global_bigstring := '';
global_boolean := false;
global_char := #0;
end;
procedure clear_values;
begin
value_u8bit := 0;
value_u16bit := 0;
value_s32bit := 0;
value_s64bit := 0;
value_s32real := 0.0;
value_s64real := 0.0;
value_proc := nil;
value_ptr := nil;
value_class := nil;
fillchar(value_smallrec, sizeof(value_smallrec), #0);
fillchar(value_largerec, sizeof(value_largerec), #0);
value_smallset := [];
value_smallstring := '';
value_bigstring := '';
value_largeset := [];
fillchar(value_smallarray, sizeof(value_smallarray), #0);
value_boolean := false;
value_char:=#0;
end;
procedure testprocedure;
begin
end;
function getu8bit : byte;
begin
getu8bit:=RESULT_U8BIT;
end;
function getu16bit: word;
begin
getu16bit:=RESULT_U16BIT;
end;
function gets32bit: longint;
begin
gets32bit:=RESULT_S32BIT;
end;
function gets64bit: int64;
begin
gets64bit:=RESULT_S64BIT;
end;
function gets32real: single;
begin
gets32real:=RESULT_S32REAL;
end;
function gets64real: double;
begin
gets64real:=RESULT_S64REAL;
end;
{************************************************************************}
{ VAR PARAMETERS }
{************************************************************************}
procedure proc_var_s32bit(var v : longint);saveregisters;
begin
v:=RESULT_S32BIT;
end;
procedure proc_var_s64bit(var v: int64);saveregisters;
begin
v:=RESULT_S64BIT;
end;
procedure proc_var_u8bit(var v: byte);saveregisters;
begin
v:=RESULT_U8BIT;
end;
procedure proc_var_smallrecord(var smallrec : tsmallrecord);saveregisters;
begin
smallrec.b := RESULT_U8BIT;
smallrec.w := RESULT_U16BIT;
end;
procedure proc_var_largerecord(var largerec : tlargerecord);saveregisters;
begin
largerec.b[1] := RESULT_U8BIT;
largerec.b[2] := RESULT_U8BIT;
end;
procedure proc_var_smallset(var smallset : tsmallset);saveregisters;
begin
smallset := [A_A,A_D];
end;
procedure proc_var_largeset(var largeset : tlargeset);saveregisters;
begin
largeset:= largeset + ['I'];
end;
procedure proc_var_smallstring(var s:tsmallstring);saveregisters;
begin
s:=RESULT_SMALLSTRING;
end;
procedure proc_var_bigstring(var s:shortstring);saveregisters;
begin
s:=RESULT_BIGSTRING;
end;
procedure proc_var_openstring(var s: OpenString);saveregisters;
begin
global_u8bit := high(s);
s:=RESULT_SMALLSTRING;
end;
procedure proc_var_smallarray(var arr : tsmallarray);saveregisters;
begin
arr[SMALL_INDEX] := RESULT_U8BIT;
arr[1] := RESULT_U8BIT;
end;
procedure proc_var_smallarray_open(var arr : array of byte);saveregisters;
begin
arr[high(arr)] := RESULT_U8BIT;
arr[low(arr)] := RESULT_U8BIT;
end;
procedure proc_var_smallarray_const_1(var arr : array of const);saveregisters;
var
i: integer;
begin
for i:=0 to high(arr) do
begin
case arr[i].vtype of
vtInteger : arr[i].vinteger := RESULT_U8BIT;
vtBoolean : arr[i].vboolean := RESULT_BOOLEAN;
else
RunError(255);
end;
end; {endfor}
end;
procedure proc_var_smallarray_const_2(var arr : array of const);saveregisters;
var
i: integer;
begin
if high(arr)<0 then
global_u8bit := RESULT_U8BIT;
end;
procedure proc_var_formaldef_array(var buf);saveregisters;
var
p: pbytearr;
begin
{ array is indexed from 1 }
p := @buf;
p[SMALL_INDEX-1] := RESULT_U8BIT;
p[0] := RESULT_U8BIT;
end;
procedure proc_var_formaldef_string(var buf);saveregisters;
var
p: pbytearr;
begin
{ array is indexed from 1 }
p := @buf;
p[SMALL_INDEX-1] := RESULT_U8BIT;
p[0] := RESULT_U8BIT;
end;
{************************************************************************}
{ MIXED VAR PARAMETERS }
{************************************************************************}
procedure proc_var_s32bit_mixed(b1 : byte;var v : longint; b2: byte);saveregisters;
begin
v:=RESULT_S32BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_s64bit_mixed(b1 : byte;var v: int64; b2: byte);saveregisters;
begin
v:=RESULT_S64BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_u8bit_mixed(b1 : byte;var v: byte; b2: byte);saveregisters;
begin
v:=RESULT_U8BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_smallrecord_mixed(b1 : byte; var smallrec : tsmallrecord; b2: byte);saveregisters;
begin
smallrec.b := RESULT_U8BIT;
smallrec.w := RESULT_U16BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_largerecord_mixed(b1 : byte; var largerec : tlargerecord; b2: byte);saveregisters;
begin
largerec.b[1] := RESULT_U8BIT;
largerec.b[2] := RESULT_U8BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_smallset_mixed(b1 : byte; var smallset : tsmallset; b2: byte);saveregisters;
begin
smallset := [A_A,A_D];
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_largeset_mixed(b1 : byte; var largeset : tlargeset; b2: byte);saveregisters;
begin
largeset:= largeset + ['I'];
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_smallstring_mixed(b1 : byte; var s:tsmallstring; b2: byte);saveregisters;
begin
s:=RESULT_SMALLSTRING;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_bigstring_mixed(b1 : byte; var s:shortstring; b2: byte);saveregisters;
begin
s:=RESULT_BIGSTRING;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_openstring_mixed(b1 : byte; var s: OpenString; b2: byte);saveregisters;
begin
global_u8bit := high(s);
s:=RESULT_SMALLSTRING;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_smallarray_mixed(b1 : byte; var arr : tsmallarray; b2: byte);saveregisters;
begin
arr[SMALL_INDEX] := RESULT_U8BIT;
arr[1] := RESULT_U8BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_smallarray_open_mixed(b1 : byte; var arr : array of byte; b2: byte);saveregisters;
begin
arr[high(arr)] := RESULT_U8BIT;
arr[low(arr)] := RESULT_U8BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_smallarray_const_1_mixed(b1 : byte; var arr : array of const; b2: byte);saveregisters;
var
i: integer;
begin
for i:=0 to high(arr) do
begin
case arr[i].vtype of
vtInteger : arr[i].vinteger := RESULT_U8BIT;
vtBoolean : arr[i].vboolean := RESULT_BOOLEAN;
else
RunError(255);
end;
end; {endfor}
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_smallarray_const_2_mixed(b1 : byte; var arr : array of const; b2: byte);saveregisters;
var
i: integer;
begin
if high(arr)<0 then
global_u8bit := RESULT_U8BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_formaldef_array_mixed(b1 : byte; var buf; b2: byte);saveregisters;
var
p: pbytearr;
begin
{ array is indexed from 1 }
p := @buf;
p[SMALL_INDEX-1] := RESULT_U8BIT;
p[0] := RESULT_U8BIT;
value_u8bit := RESULT_U8BIT;
end;
procedure proc_var_formaldef_string_mixed(b1 : byte; var buf; b2: byte);saveregisters;
var
p: pbytearr;
begin
{ array is indexed from 1 }
p := @buf;
p[SMALL_INDEX-1] := RESULT_U8BIT;
p[0] := RESULT_U8BIT;
value_u8bit := RESULT_U8BIT;
end;
var
failed: boolean;
pp : ^pchar;
begin
{***************************** NORMAL TESTS *******************************}
clear_globals;
clear_values;
failed:=false;
write('Var parameter test (src : LOC_REFERENCE (orddef)))...');
proc_var_s32bit(global_s32bit);
if global_s32bit <> RESULT_S32BIT then
failed:=true;
clear_globals;
clear_values;
proc_var_s64bit(global_s64bit);
if global_s64bit <> RESULT_S64BIT then
failed:=true;
clear_globals;
clear_values;
proc_var_u8bit(global_u8bit);
if global_u8bit <> RESULT_U8BIT then
failed:=true;
if failed then
fail
else
WriteLn('Passed!');
write('Var parameter test (src : LOC_REFERENCE (recorddef)))...');
clear_globals;
clear_values;
failed := false;
proc_var_smallrecord(value_smallrec);
if (value_smallrec.b <> RESULT_U8BIT) or (value_smallrec.w <> RESULT_U16BIT) then
failed := true;
clear_globals;
clear_values;
proc_var_largerecord(value_largerec);
if (value_largerec.b[1] <> RESULT_U8BIT) or (value_largerec.b[2] <> RESULT_U8BIT) then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('var parameter test (src : LOC_REFERENCE (setdef)))...');
clear_globals;
clear_values;
failed := false;
proc_var_smallset(value_smallset);
if (not (A_A in value_smallset)) or (not (A_D in value_smallset)) then
failed := true;
clear_globals;
clear_values;
proc_var_largeset(value_largeset);
if not ('I' in value_largeset) then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('var parameter test (src : LOC_REFERENCE (stringdef)))...');
clear_globals;
clear_values;
failed := false;
proc_var_smallstring(value_smallstring);
if value_smallstring <> RESULT_SMALLSTRING then
failed := true;
clear_globals;
clear_values;
proc_var_bigstring(value_bigstring);
if value_bigstring <> RESULT_BIGSTRING then
failed := true;
clear_globals;
clear_values;
proc_var_openstring(value_smallstring);
if (value_smallstring <> RESULT_SMALLSTRING) or (global_u8bit <> high(value_smallstring)) then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Var parameter test (src : LOC_REFERENCE (formaldef)))...');
clear_globals;
clear_values;
failed:=false;
proc_var_formaldef_array(value_smallarray);
if (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) or (value_smallarray[1] <> RESULT_U8BIT) then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Var parameter test (src : LOC_REFERENCE (arraydef)))...');
clear_globals;
clear_values;
failed:=false;
value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
proc_var_smallarray(value_smallarray);
if (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) or (value_smallarray[1] <> RESULT_U8BIT) then
failed := true;
clear_globals;
clear_values;
proc_var_smallarray_open(value_smallarray);
if (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) or (value_smallarray[1] <> RESULT_U8BIT) then
failed := true;
(* HOW CAN ARRAY OF CONST VAR PARAMETERS BE TESTED?
clear_globals;
clear_values;
value_u8bit := RESULT_U8BIT;
value_ptr := RESULT_PCHAR;
value_s64bit := RESULT_S64BIT;
value_smallstring := RESULT_SMALLSTRING;
value_class := tclass1.create;
value_boolean := RESULT_BOOLEAN;
value_char := RESULT_CHAR;
value_s64real:=RESULT_S64REAL;
proc_var_smallarray_var_1([value_u8bit,value_ptr,value_s64bit,value_char,value_smallstring,value_s64real,value_boolean,value_class]);
if global_u8bit <> RESULT_U8BIT then
failed := true;
if global_char <> RESULT_CHAR then
failed := true;
if global_boolean <> RESULT_BOOLEAN then
failed:=true;
if trunc(global_s64real) <> trunc(RESULT_S64REAL) then
failed := true;
if global_bigstring <> RESULT_SMALLSTRING then
failed := true;
if global_ptr <> value_ptr then
failed := true;
{ if value_class <> global_class then
failed := true;!!!!!!!!!!!!!!!!!!!!}
if global_s64bit <> RESULT_S64BIT then
failed := true;
if assigned(value_class) then
value_class.destroy;
global_u8bit := 0;
proc_var_smallarray_const_2([]);
if global_u8bit <> RESULT_U8BIT then
failed := true;
*)
if failed then
fail
else
WriteLn('Passed!');
{***************************** MIXED TESTS *******************************}
clear_globals;
clear_values;
failed:=false;
write('Var parameter test (src : LOC_REFERENCE (orddef)))...');
proc_var_s32bit_mixed(RESULT_U8BIT, global_s32bit, RESULT_U8BIT);
if global_s32bit <> RESULT_S32BIT then
failed:=true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
proc_var_s64bit_mixed(RESULT_U8BIT, global_s64bit, RESULT_U8BIT);
if global_s64bit <> RESULT_S64BIT then
failed:=true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
proc_var_u8bit_mixed(RESULT_U8BIT, global_u8bit, RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed:=true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Var parameter test (src : LOC_REFERENCE (recorddef)))...');
clear_globals;
clear_values;
failed := false;
proc_var_smallrecord_mixed(RESULT_U8BIT,value_smallrec, RESULT_U8BIT);
if (value_smallrec.b <> RESULT_U8BIT) or (value_smallrec.w <> RESULT_U16BIT) then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
proc_var_largerecord_mixed(RESULT_U8BIT, value_largerec, RESULT_U8BIT);
if (value_largerec.b[1] <> RESULT_U8BIT) or (value_largerec.b[2] <> RESULT_U8BIT) then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('var parameter test (src : LOC_REFERENCE (setdef)))...');
clear_globals;
clear_values;
failed := false;
proc_var_smallset_mixed(RESULT_U8BIT, value_smallset, RESULT_U8BIT);
if (not (A_A in value_smallset)) or (not (A_D in value_smallset)) then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
proc_var_largeset_mixed(RESULT_U8BIT, value_largeset, RESULT_U8BIT);
if not ('I' in value_largeset) then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('var parameter test (src : LOC_REFERENCE (stringdef)))...');
clear_globals;
clear_values;
failed := false;
proc_var_smallstring_mixed(RESULT_U8BIT, value_smallstring, RESULT_U8BIT);
if value_smallstring <> RESULT_SMALLSTRING then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
proc_var_bigstring_mixed(RESULT_U8BIT, value_bigstring,RESULT_U8BIT);
if value_bigstring <> RESULT_BIGSTRING then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
proc_var_openstring_mixed(RESULT_U8BIT, value_smallstring, RESULT_U8BIT);
if (value_smallstring <> RESULT_SMALLSTRING) or (global_u8bit <> high(value_smallstring)) then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Var parameter test (src : LOC_REFERENCE (formaldef)))...');
clear_globals;
clear_values;
failed:=false;
proc_var_formaldef_array_mixed(RESULT_U8BIT, value_smallarray, RESULT_U8BIT);
if (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) or (value_smallarray[1] <> RESULT_U8BIT) then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
write('Var parameter test (src : LOC_REFERENCE (arraydef)))...');
clear_globals;
clear_values;
failed:=false;
value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
proc_var_smallarray_mixed(RESULT_U8BIT, value_smallarray, RESULT_U8BIT);
if (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) or (value_smallarray[1] <> RESULT_U8BIT) then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
clear_globals;
clear_values;
proc_var_smallarray_open_mixed(RESULT_U8BIT, value_smallarray, RESULT_U8BIT);
if (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) or (value_smallarray[1] <> RESULT_U8BIT) then
failed := true;
if value_u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Passed!');
end.