mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 11:09:42 +02:00
+ finished procedural variable testsuit
+ finished method testsuit
This commit is contained in:
carl
parent
463476932c
commit
fcbb1eea4e
2128
tests/test/cg/tcalobj1.pp
Normal file
2128
tests/test/cg/tcalobj1.pp
Normal file
File diff suppressed because it is too large
Load Diff
2129
tests/test/cg/tcalobj2.pp
Normal file
2129
tests/test/cg/tcalobj2.pp
Normal file
File diff suppressed because it is too large
Load Diff
2129
tests/test/cg/tcalobj3.pp
Normal file
2129
tests/test/cg/tcalobj3.pp
Normal file
File diff suppressed because it is too large
Load Diff
2129
tests/test/cg/tcalobj4.pp
Normal file
2129
tests/test/cg/tcalobj4.pp
Normal file
File diff suppressed because it is too large
Load Diff
2129
tests/test/cg/tcalobj5.pp
Normal file
2129
tests/test/cg/tcalobj5.pp
Normal file
File diff suppressed because it is too large
Load Diff
2129
tests/test/cg/tcalobj6.pp
Normal file
2129
tests/test/cg/tcalobj6.pp
Normal file
File diff suppressed because it is too large
Load Diff
2129
tests/test/cg/tcalobj7.pp
Normal file
2129
tests/test/cg/tcalobj7.pp
Normal file
File diff suppressed because it is too large
Load Diff
2129
tests/test/cg/tcalobj8.pp
Normal file
2129
tests/test/cg/tcalobj8.pp
Normal file
File diff suppressed because it is too large
Load Diff
608
tests/test/cg/tcalpvr2.pp
Normal file
608
tests/test/cg/tcalpvr2.pp
Normal file
@ -0,0 +1,608 @@
|
||||
{****************************************************************}
|
||||
{ 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 pascal }
|
||||
{ calling conventions. }
|
||||
{****************************************************************}
|
||||
program tcalpvr2;
|
||||
{$MODE OBJFPC}
|
||||
{$STATIC ON}
|
||||
{$R+}
|
||||
|
||||
const
|
||||
RESULT_U8BIT = $55;
|
||||
RESULT_U16BIT = $500F;
|
||||
RESULT_S32BIT = $500F0000;
|
||||
RESULT_S64BIT = -12000;
|
||||
|
||||
type
|
||||
|
||||
troutine = procedure (x: longint; y: byte);pascal;
|
||||
troutineresult = function (x: longint; y: byte): int64;pascal;
|
||||
|
||||
tsimpleobject = object
|
||||
constructor init;pascal;
|
||||
procedure test_normal(x: byte);pascal;
|
||||
procedure test_static(x: byte);static;pascal;
|
||||
procedure test_virtual(x: byte);virtual;pascal;
|
||||
end;
|
||||
|
||||
tsimpleclass = class
|
||||
constructor create;pascal;
|
||||
procedure test_normal(x: byte);pascal;
|
||||
class procedure test_static(x: byte);pascal;
|
||||
procedure test_virtual(x: byte);virtual;pascal;
|
||||
procedure test_normal_self(self : tsimpleclass; x: byte); message 0;pascal;
|
||||
class procedure test_static_self(self : tsimpleclass; x: byte); message 1;pascal;
|
||||
procedure test_virtual_self(self : tsimpleclass; x: byte);virtual;message 2;pascal;
|
||||
end;
|
||||
|
||||
tobjectmethod = procedure (x: byte) of object ;pascal;
|
||||
tclassmethod = procedure (x: byte) of object;pascal;
|
||||
{ used for testing pocontainsself explicit parameter }
|
||||
tclassmethodself = procedure (self : tsimpleclass; x: byte) of object;pascal;
|
||||
|
||||
var
|
||||
proc : troutine;
|
||||
func : troutineresult;
|
||||
obj_method : tobjectmethod;
|
||||
cla_method : tclassmethod;
|
||||
cla_method_self : tclassmethodself;
|
||||
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);pascal;
|
||||
begin
|
||||
global_s32bit := x;
|
||||
global_u8bit := y;
|
||||
end;
|
||||
|
||||
function testroutineresult(x: longint; y: byte): int64;pascal;
|
||||
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 := @tsimpleobject.test_virtual;
|
||||
end;
|
||||
|
||||
function get_object_method_virtual : tobjectmethod;
|
||||
begin
|
||||
get_object_method_virtual := @obj.test_virtual;
|
||||
end;
|
||||
|
||||
{ class access }
|
||||
function get_class_method_normal_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_normal_self := @tsimpleclass.test_normal_self;
|
||||
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_virtual_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_virtual_self := @tsimpleclass.test_virtual_self;
|
||||
end;
|
||||
|
||||
|
||||
function get_class_method_normal : tclassmethod;
|
||||
begin
|
||||
get_class_method_normal := @tsimpleclass.test_normal;
|
||||
end;
|
||||
{
|
||||
function get_class_method_static : tclassmethod;
|
||||
begin
|
||||
get_class_method_static := @tsimpleclass.test_static;
|
||||
end;}
|
||||
|
||||
function get_class_method_virtual : tclassmethod;
|
||||
begin
|
||||
get_class_method_virtual := @tsimpleclass.test_virtual;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
constructor tsimpleobject.init;pascal;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_normal(x: byte);pascal;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_static(x: byte);pascal;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_virtual(x: byte);pascal;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
constructor tsimpleclass.create;pascal;
|
||||
begin
|
||||
inherited create;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass. test_normal(x: byte);pascal;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static(x: byte);pascal;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual(x: byte);pascal;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);pascal;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);pascal;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual_self(self : tsimpleclass; x: byte);pascal;
|
||||
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:=@tsimpleobject.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:=@tsimpleobject.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;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tclassmethodself(get_class_method_normal_self)(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
tclassmethodself(get_class_method_virtual_self)(cla,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 := @tsimpleclass.test_normal;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_normal_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-05-05 13:58:50 carl
|
||||
+ finished procedural variable testsuit
|
||||
+ finished method testsuit
|
||||
|
||||
}
|
||||
608
tests/test/cg/tcalpvr3.pp
Normal file
608
tests/test/cg/tcalpvr3.pp
Normal file
@ -0,0 +1,608 @@
|
||||
{****************************************************************}
|
||||
{ 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 cdecl }
|
||||
{ calling conventions. }
|
||||
{****************************************************************}
|
||||
program tcalpvr3;
|
||||
{$MODE OBJFPC}
|
||||
{$STATIC ON}
|
||||
{$R+}
|
||||
|
||||
const
|
||||
RESULT_U8BIT = $55;
|
||||
RESULT_U16BIT = $500F;
|
||||
RESULT_S32BIT = $500F0000;
|
||||
RESULT_S64BIT = -12000;
|
||||
|
||||
type
|
||||
|
||||
troutine = procedure (x: longint; y: byte);cdecl;
|
||||
troutineresult = function (x: longint; y: byte): int64;cdecl;
|
||||
|
||||
tsimpleobject = object
|
||||
constructor init;cdecl;
|
||||
procedure test_normal(x: byte);cdecl;
|
||||
procedure test_static(x: byte);static;cdecl;
|
||||
procedure test_virtual(x: byte);virtual;cdecl;
|
||||
end;
|
||||
|
||||
tsimpleclass = class
|
||||
constructor create;cdecl;
|
||||
procedure test_normal(x: byte);cdecl;
|
||||
class procedure test_static(x: byte);cdecl;
|
||||
procedure test_virtual(x: byte);virtual;cdecl;
|
||||
procedure test_normal_self(self : tsimpleclass; x: byte); message 0;cdecl;
|
||||
class procedure test_static_self(self : tsimpleclass; x: byte); message 1;cdecl;
|
||||
procedure test_virtual_self(self : tsimpleclass; x: byte);virtual;message 2;cdecl;
|
||||
end;
|
||||
|
||||
tobjectmethod = procedure (x: byte) of object ;cdecl;
|
||||
tclassmethod = procedure (x: byte) of object;cdecl;
|
||||
{ used for testing pocontainsself explicit parameter }
|
||||
tclassmethodself = procedure (self : tsimpleclass; x: byte) of object;cdecl;
|
||||
|
||||
var
|
||||
proc : troutine;
|
||||
func : troutineresult;
|
||||
obj_method : tobjectmethod;
|
||||
cla_method : tclassmethod;
|
||||
cla_method_self : tclassmethodself;
|
||||
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);cdecl;
|
||||
begin
|
||||
global_s32bit := x;
|
||||
global_u8bit := y;
|
||||
end;
|
||||
|
||||
function testroutineresult(x: longint; y: byte): int64;cdecl;
|
||||
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 := @tsimpleobject.test_virtual;
|
||||
end;
|
||||
|
||||
function get_object_method_virtual : tobjectmethod;
|
||||
begin
|
||||
get_object_method_virtual := @obj.test_virtual;
|
||||
end;
|
||||
|
||||
{ class access }
|
||||
function get_class_method_normal_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_normal_self := @tsimpleclass.test_normal_self;
|
||||
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_virtual_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_virtual_self := @tsimpleclass.test_virtual_self;
|
||||
end;
|
||||
|
||||
|
||||
function get_class_method_normal : tclassmethod;
|
||||
begin
|
||||
get_class_method_normal := @tsimpleclass.test_normal;
|
||||
end;
|
||||
{
|
||||
function get_class_method_static : tclassmethod;
|
||||
begin
|
||||
get_class_method_static := @tsimpleclass.test_static;
|
||||
end;}
|
||||
|
||||
function get_class_method_virtual : tclassmethod;
|
||||
begin
|
||||
get_class_method_virtual := @tsimpleclass.test_virtual;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
constructor tsimpleobject.init;cdecl;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_normal(x: byte);cdecl;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_static(x: byte);cdecl;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_virtual(x: byte);cdecl;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
constructor tsimpleclass.create;cdecl;
|
||||
begin
|
||||
inherited create;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass. test_normal(x: byte);cdecl;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static(x: byte);cdecl;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual(x: byte);cdecl;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);cdecl;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);cdecl;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual_self(self : tsimpleclass; x: byte);cdecl;
|
||||
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:=@tsimpleobject.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:=@tsimpleobject.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;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tclassmethodself(get_class_method_normal_self)(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
tclassmethodself(get_class_method_virtual_self)(cla,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 := @tsimpleclass.test_normal;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_normal_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-05-05 13:58:50 carl
|
||||
+ finished procedural variable testsuit
|
||||
+ finished method testsuit
|
||||
|
||||
}
|
||||
608
tests/test/cg/tcalpvr4.pp
Normal file
608
tests/test/cg/tcalpvr4.pp
Normal file
@ -0,0 +1,608 @@
|
||||
{****************************************************************}
|
||||
{ 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 popstack }
|
||||
{ calling conventions. }
|
||||
{****************************************************************}
|
||||
program tcalpvr4;
|
||||
{$MODE OBJFPC}
|
||||
{$STATIC ON}
|
||||
{$R+}
|
||||
|
||||
const
|
||||
RESULT_U8BIT = $55;
|
||||
RESULT_U16BIT = $500F;
|
||||
RESULT_S32BIT = $500F0000;
|
||||
RESULT_S64BIT = -12000;
|
||||
|
||||
type
|
||||
|
||||
troutine = procedure (x: longint; y: byte);popstack;
|
||||
troutineresult = function (x: longint; y: byte): int64;popstack;
|
||||
|
||||
tsimpleobject = object
|
||||
constructor init;popstack;
|
||||
procedure test_normal(x: byte);popstack;
|
||||
procedure test_static(x: byte);static;popstack;
|
||||
procedure test_virtual(x: byte);virtual;popstack;
|
||||
end;
|
||||
|
||||
tsimpleclass = class
|
||||
constructor create;popstack;
|
||||
procedure test_normal(x: byte);popstack;
|
||||
class procedure test_static(x: byte);popstack;
|
||||
procedure test_virtual(x: byte);virtual;popstack;
|
||||
procedure test_normal_self(self : tsimpleclass; x: byte); message 0;popstack;
|
||||
class procedure test_static_self(self : tsimpleclass; x: byte); message 1;popstack;
|
||||
procedure test_virtual_self(self : tsimpleclass; x: byte);virtual;message 2;popstack;
|
||||
end;
|
||||
|
||||
tobjectmethod = procedure (x: byte) of object ;popstack;
|
||||
tclassmethod = procedure (x: byte) of object;popstack;
|
||||
{ used for testing pocontainsself explicit parameter }
|
||||
tclassmethodself = procedure (self : tsimpleclass; x: byte) of object;popstack;
|
||||
|
||||
var
|
||||
proc : troutine;
|
||||
func : troutineresult;
|
||||
obj_method : tobjectmethod;
|
||||
cla_method : tclassmethod;
|
||||
cla_method_self : tclassmethodself;
|
||||
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);popstack;
|
||||
begin
|
||||
global_s32bit := x;
|
||||
global_u8bit := y;
|
||||
end;
|
||||
|
||||
function testroutineresult(x: longint; y: byte): int64;popstack;
|
||||
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 := @tsimpleobject.test_virtual;
|
||||
end;
|
||||
|
||||
function get_object_method_virtual : tobjectmethod;
|
||||
begin
|
||||
get_object_method_virtual := @obj.test_virtual;
|
||||
end;
|
||||
|
||||
{ class access }
|
||||
function get_class_method_normal_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_normal_self := @tsimpleclass.test_normal_self;
|
||||
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_virtual_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_virtual_self := @tsimpleclass.test_virtual_self;
|
||||
end;
|
||||
|
||||
|
||||
function get_class_method_normal : tclassmethod;
|
||||
begin
|
||||
get_class_method_normal := @tsimpleclass.test_normal;
|
||||
end;
|
||||
{
|
||||
function get_class_method_static : tclassmethod;
|
||||
begin
|
||||
get_class_method_static := @tsimpleclass.test_static;
|
||||
end;}
|
||||
|
||||
function get_class_method_virtual : tclassmethod;
|
||||
begin
|
||||
get_class_method_virtual := @tsimpleclass.test_virtual;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
constructor tsimpleobject.init;popstack;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_normal(x: byte);popstack;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_static(x: byte);popstack;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_virtual(x: byte);popstack;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
constructor tsimpleclass.create;popstack;
|
||||
begin
|
||||
inherited create;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass. test_normal(x: byte);popstack;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static(x: byte);popstack;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual(x: byte);popstack;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);popstack;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);popstack;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual_self(self : tsimpleclass; x: byte);popstack;
|
||||
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:=@tsimpleobject.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:=@tsimpleobject.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;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tclassmethodself(get_class_method_normal_self)(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
tclassmethodself(get_class_method_virtual_self)(cla,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 := @tsimpleclass.test_normal;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_normal_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-05-05 13:58:50 carl
|
||||
+ finished procedural variable testsuit
|
||||
+ finished method testsuit
|
||||
|
||||
}
|
||||
608
tests/test/cg/tcalpvr5.pp
Normal file
608
tests/test/cg/tcalpvr5.pp
Normal file
@ -0,0 +1,608 @@
|
||||
{****************************************************************}
|
||||
{ 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 safecall }
|
||||
{ calling conventions. }
|
||||
{****************************************************************}
|
||||
program tcalpvr5;
|
||||
{$MODE OBJFPC}
|
||||
{$STATIC ON}
|
||||
{$R+}
|
||||
|
||||
const
|
||||
RESULT_U8BIT = $55;
|
||||
RESULT_U16BIT = $500F;
|
||||
RESULT_S32BIT = $500F0000;
|
||||
RESULT_S64BIT = -12000;
|
||||
|
||||
type
|
||||
|
||||
troutine = procedure (x: longint; y: byte);safecall;
|
||||
troutineresult = function (x: longint; y: byte): int64;safecall;
|
||||
|
||||
tsimpleobject = object
|
||||
constructor init;safecall;
|
||||
procedure test_normal(x: byte);safecall;
|
||||
procedure test_static(x: byte);static;safecall;
|
||||
procedure test_virtual(x: byte);virtual;safecall;
|
||||
end;
|
||||
|
||||
tsimpleclass = class
|
||||
constructor create;safecall;
|
||||
procedure test_normal(x: byte);safecall;
|
||||
class procedure test_static(x: byte);safecall;
|
||||
procedure test_virtual(x: byte);virtual;safecall;
|
||||
procedure test_normal_self(self : tsimpleclass; x: byte); message 0;safecall;
|
||||
class procedure test_static_self(self : tsimpleclass; x: byte); message 1;safecall;
|
||||
procedure test_virtual_self(self : tsimpleclass; x: byte);virtual;message 2;safecall;
|
||||
end;
|
||||
|
||||
tobjectmethod = procedure (x: byte) of object ;safecall;
|
||||
tclassmethod = procedure (x: byte) of object;safecall;
|
||||
{ used for testing pocontainsself explicit parameter }
|
||||
tclassmethodself = procedure (self : tsimpleclass; x: byte) of object;safecall;
|
||||
|
||||
var
|
||||
proc : troutine;
|
||||
func : troutineresult;
|
||||
obj_method : tobjectmethod;
|
||||
cla_method : tclassmethod;
|
||||
cla_method_self : tclassmethodself;
|
||||
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);safecall;
|
||||
begin
|
||||
global_s32bit := x;
|
||||
global_u8bit := y;
|
||||
end;
|
||||
|
||||
function testroutineresult(x: longint; y: byte): int64;safecall;
|
||||
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 := @tsimpleobject.test_virtual;
|
||||
end;
|
||||
|
||||
function get_object_method_virtual : tobjectmethod;
|
||||
begin
|
||||
get_object_method_virtual := @obj.test_virtual;
|
||||
end;
|
||||
|
||||
{ class access }
|
||||
function get_class_method_normal_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_normal_self := @tsimpleclass.test_normal_self;
|
||||
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_virtual_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_virtual_self := @tsimpleclass.test_virtual_self;
|
||||
end;
|
||||
|
||||
|
||||
function get_class_method_normal : tclassmethod;
|
||||
begin
|
||||
get_class_method_normal := @tsimpleclass.test_normal;
|
||||
end;
|
||||
{
|
||||
function get_class_method_static : tclassmethod;
|
||||
begin
|
||||
get_class_method_static := @tsimpleclass.test_static;
|
||||
end;}
|
||||
|
||||
function get_class_method_virtual : tclassmethod;
|
||||
begin
|
||||
get_class_method_virtual := @tsimpleclass.test_virtual;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
constructor tsimpleobject.init;safecall;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_normal(x: byte);safecall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_static(x: byte);safecall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_virtual(x: byte);safecall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
constructor tsimpleclass.create;safecall;
|
||||
begin
|
||||
inherited create;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass. test_normal(x: byte);safecall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static(x: byte);safecall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual(x: byte);safecall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);safecall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);safecall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual_self(self : tsimpleclass; x: byte);safecall;
|
||||
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:=@tsimpleobject.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:=@tsimpleobject.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;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tclassmethodself(get_class_method_normal_self)(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
tclassmethodself(get_class_method_virtual_self)(cla,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 := @tsimpleclass.test_normal;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_normal_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-05-05 13:58:50 carl
|
||||
+ finished procedural variable testsuit
|
||||
+ finished method testsuit
|
||||
|
||||
}
|
||||
608
tests/test/cg/tcalpvr6.pp
Normal file
608
tests/test/cg/tcalpvr6.pp
Normal file
@ -0,0 +1,608 @@
|
||||
{****************************************************************}
|
||||
{ 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 register }
|
||||
{ calling conventions. }
|
||||
{****************************************************************}
|
||||
program tcalpvr6;
|
||||
{$MODE OBJFPC}
|
||||
{$STATIC ON}
|
||||
{$R+}
|
||||
|
||||
const
|
||||
RESULT_U8BIT = $55;
|
||||
RESULT_U16BIT = $500F;
|
||||
RESULT_S32BIT = $500F0000;
|
||||
RESULT_S64BIT = -12000;
|
||||
|
||||
type
|
||||
|
||||
troutine = procedure (x: longint; y: byte);register;
|
||||
troutineresult = function (x: longint; y: byte): int64;register;
|
||||
|
||||
tsimpleobject = object
|
||||
constructor init;register;
|
||||
procedure test_normal(x: byte);register;
|
||||
procedure test_static(x: byte);static;register;
|
||||
procedure test_virtual(x: byte);virtual;register;
|
||||
end;
|
||||
|
||||
tsimpleclass = class
|
||||
constructor create;register;
|
||||
procedure test_normal(x: byte);register;
|
||||
class procedure test_static(x: byte);register;
|
||||
procedure test_virtual(x: byte);virtual;register;
|
||||
procedure test_normal_self(self : tsimpleclass; x: byte); message 0;register;
|
||||
class procedure test_static_self(self : tsimpleclass; x: byte); message 1;register;
|
||||
procedure test_virtual_self(self : tsimpleclass; x: byte);virtual;message 2;register;
|
||||
end;
|
||||
|
||||
tobjectmethod = procedure (x: byte) of object ;register;
|
||||
tclassmethod = procedure (x: byte) of object;register;
|
||||
{ used for testing pocontainsself explicit parameter }
|
||||
tclassmethodself = procedure (self : tsimpleclass; x: byte) of object;register;
|
||||
|
||||
var
|
||||
proc : troutine;
|
||||
func : troutineresult;
|
||||
obj_method : tobjectmethod;
|
||||
cla_method : tclassmethod;
|
||||
cla_method_self : tclassmethodself;
|
||||
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);register;
|
||||
begin
|
||||
global_s32bit := x;
|
||||
global_u8bit := y;
|
||||
end;
|
||||
|
||||
function testroutineresult(x: longint; y: byte): int64;register;
|
||||
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 := @tsimpleobject.test_virtual;
|
||||
end;
|
||||
|
||||
function get_object_method_virtual : tobjectmethod;
|
||||
begin
|
||||
get_object_method_virtual := @obj.test_virtual;
|
||||
end;
|
||||
|
||||
{ class access }
|
||||
function get_class_method_normal_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_normal_self := @tsimpleclass.test_normal_self;
|
||||
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_virtual_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_virtual_self := @tsimpleclass.test_virtual_self;
|
||||
end;
|
||||
|
||||
|
||||
function get_class_method_normal : tclassmethod;
|
||||
begin
|
||||
get_class_method_normal := @tsimpleclass.test_normal;
|
||||
end;
|
||||
{
|
||||
function get_class_method_static : tclassmethod;
|
||||
begin
|
||||
get_class_method_static := @tsimpleclass.test_static;
|
||||
end;}
|
||||
|
||||
function get_class_method_virtual : tclassmethod;
|
||||
begin
|
||||
get_class_method_virtual := @tsimpleclass.test_virtual;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
constructor tsimpleobject.init;register;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_normal(x: byte);register;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_static(x: byte);register;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_virtual(x: byte);register;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
constructor tsimpleclass.create;register;
|
||||
begin
|
||||
inherited create;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass. test_normal(x: byte);register;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static(x: byte);register;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual(x: byte);register;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);register;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);register;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual_self(self : tsimpleclass; x: byte);register;
|
||||
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:=@tsimpleobject.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:=@tsimpleobject.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;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tclassmethodself(get_class_method_normal_self)(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
tclassmethodself(get_class_method_virtual_self)(cla,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 := @tsimpleclass.test_normal;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_normal_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-05-05 13:58:50 carl
|
||||
+ finished procedural variable testsuit
|
||||
+ finished method testsuit
|
||||
|
||||
}
|
||||
608
tests/test/cg/tcalpvr7.pp
Normal file
608
tests/test/cg/tcalpvr7.pp
Normal file
@ -0,0 +1,608 @@
|
||||
{****************************************************************}
|
||||
{ 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 stdcall }
|
||||
{ calling conventions. }
|
||||
{****************************************************************}
|
||||
program tcalpvr7;
|
||||
{$MODE OBJFPC}
|
||||
{$STATIC ON}
|
||||
{$R+}
|
||||
|
||||
const
|
||||
RESULT_U8BIT = $55;
|
||||
RESULT_U16BIT = $500F;
|
||||
RESULT_S32BIT = $500F0000;
|
||||
RESULT_S64BIT = -12000;
|
||||
|
||||
type
|
||||
|
||||
troutine = procedure (x: longint; y: byte);stdcall;
|
||||
troutineresult = function (x: longint; y: byte): int64;stdcall;
|
||||
|
||||
tsimpleobject = object
|
||||
constructor init;stdcall;
|
||||
procedure test_normal(x: byte);stdcall;
|
||||
procedure test_static(x: byte);static;stdcall;
|
||||
procedure test_virtual(x: byte);virtual;stdcall;
|
||||
end;
|
||||
|
||||
tsimpleclass = class
|
||||
constructor create;stdcall;
|
||||
procedure test_normal(x: byte);stdcall;
|
||||
class procedure test_static(x: byte);stdcall;
|
||||
procedure test_virtual(x: byte);virtual;stdcall;
|
||||
procedure test_normal_self(self : tsimpleclass; x: byte); message 0;stdcall;
|
||||
class procedure test_static_self(self : tsimpleclass; x: byte); message 1;stdcall;
|
||||
procedure test_virtual_self(self : tsimpleclass; x: byte);virtual;message 2;stdcall;
|
||||
end;
|
||||
|
||||
tobjectmethod = procedure (x: byte) of object ;stdcall;
|
||||
tclassmethod = procedure (x: byte) of object;stdcall;
|
||||
{ used for testing pocontainsself explicit parameter }
|
||||
tclassmethodself = procedure (self : tsimpleclass; x: byte) of object;stdcall;
|
||||
|
||||
var
|
||||
proc : troutine;
|
||||
func : troutineresult;
|
||||
obj_method : tobjectmethod;
|
||||
cla_method : tclassmethod;
|
||||
cla_method_self : tclassmethodself;
|
||||
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);stdcall;
|
||||
begin
|
||||
global_s32bit := x;
|
||||
global_u8bit := y;
|
||||
end;
|
||||
|
||||
function testroutineresult(x: longint; y: byte): int64;stdcall;
|
||||
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 := @tsimpleobject.test_virtual;
|
||||
end;
|
||||
|
||||
function get_object_method_virtual : tobjectmethod;
|
||||
begin
|
||||
get_object_method_virtual := @obj.test_virtual;
|
||||
end;
|
||||
|
||||
{ class access }
|
||||
function get_class_method_normal_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_normal_self := @tsimpleclass.test_normal_self;
|
||||
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_virtual_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_virtual_self := @tsimpleclass.test_virtual_self;
|
||||
end;
|
||||
|
||||
|
||||
function get_class_method_normal : tclassmethod;
|
||||
begin
|
||||
get_class_method_normal := @tsimpleclass.test_normal;
|
||||
end;
|
||||
{
|
||||
function get_class_method_static : tclassmethod;
|
||||
begin
|
||||
get_class_method_static := @tsimpleclass.test_static;
|
||||
end;}
|
||||
|
||||
function get_class_method_virtual : tclassmethod;
|
||||
begin
|
||||
get_class_method_virtual := @tsimpleclass.test_virtual;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
constructor tsimpleobject.init;stdcall;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_normal(x: byte);stdcall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_static(x: byte);stdcall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_virtual(x: byte);stdcall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
constructor tsimpleclass.create;stdcall;
|
||||
begin
|
||||
inherited create;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass. test_normal(x: byte);stdcall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static(x: byte);stdcall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual(x: byte);stdcall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);stdcall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);stdcall;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual_self(self : tsimpleclass; x: byte);stdcall;
|
||||
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:=@tsimpleobject.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:=@tsimpleobject.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;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tclassmethodself(get_class_method_normal_self)(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
tclassmethodself(get_class_method_virtual_self)(cla,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 := @tsimpleclass.test_normal;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_normal_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-05-05 13:58:50 carl
|
||||
+ finished procedural variable testsuit
|
||||
+ finished method testsuit
|
||||
|
||||
}
|
||||
608
tests/test/cg/tcalpvr8.pp
Normal file
608
tests/test/cg/tcalpvr8.pp
Normal file
@ -0,0 +1,608 @@
|
||||
{****************************************************************}
|
||||
{ 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 tcalpvr8;
|
||||
{$MODE OBJFPC}
|
||||
{$STATIC ON}
|
||||
{$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;saveregisters;
|
||||
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;saveregisters;
|
||||
procedure test_normal(x: byte);saveregisters;
|
||||
class procedure test_static(x: byte);saveregisters;
|
||||
procedure test_virtual(x: byte);virtual;saveregisters;
|
||||
procedure test_normal_self(self : tsimpleclass; x: byte); message 0;saveregisters;
|
||||
class procedure test_static_self(self : tsimpleclass; x: byte); message 1;saveregisters;
|
||||
procedure test_virtual_self(self : tsimpleclass; x: byte);virtual;message 2;saveregisters;
|
||||
end;
|
||||
|
||||
tobjectmethod = procedure (x: byte) of object ;saveregisters;
|
||||
tclassmethod = procedure (x: byte) of object;saveregisters;
|
||||
{ used for testing pocontainsself explicit parameter }
|
||||
tclassmethodself = procedure (self : tsimpleclass; x: byte) of object;saveregisters;
|
||||
|
||||
var
|
||||
proc : troutine;
|
||||
func : troutineresult;
|
||||
obj_method : tobjectmethod;
|
||||
cla_method : tclassmethod;
|
||||
cla_method_self : tclassmethodself;
|
||||
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 := @tsimpleobject.test_virtual;
|
||||
end;
|
||||
|
||||
function get_object_method_virtual : tobjectmethod;
|
||||
begin
|
||||
get_object_method_virtual := @obj.test_virtual;
|
||||
end;
|
||||
|
||||
{ class access }
|
||||
function get_class_method_normal_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_normal_self := @tsimpleclass.test_normal_self;
|
||||
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_virtual_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_virtual_self := @tsimpleclass.test_virtual_self;
|
||||
end;
|
||||
|
||||
|
||||
function get_class_method_normal : tclassmethod;
|
||||
begin
|
||||
get_class_method_normal := @tsimpleclass.test_normal;
|
||||
end;
|
||||
{
|
||||
function get_class_method_static : tclassmethod;
|
||||
begin
|
||||
get_class_method_static := @tsimpleclass.test_static;
|
||||
end;}
|
||||
|
||||
function get_class_method_virtual : tclassmethod;
|
||||
begin
|
||||
get_class_method_virtual := @tsimpleclass.test_virtual;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
constructor tsimpleobject.init;saveregisters;
|
||||
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;saveregisters;
|
||||
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;
|
||||
|
||||
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);saveregisters;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);saveregisters;
|
||||
begin
|
||||
global_u8bit := x;
|
||||
end;
|
||||
|
||||
procedure tsimpleclass.test_virtual_self(self : tsimpleclass; 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:=@tsimpleobject.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:=@tsimpleobject.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;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tclassmethodself(get_class_method_normal_self)(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
tclassmethodself(get_class_method_virtual_self)(cla,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 := @tsimpleclass.test_normal;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method := @tsimpleclass.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_normal_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method_self := @tsimpleclass.test_virtual_self;
|
||||
cla_method_self(cla, RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @tsimpleclass.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-05-05 13:58:50 carl
|
||||
+ finished procedural variable testsuit
|
||||
+ finished method testsuit
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user