mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-01 21:22:38 +02:00
619 lines
14 KiB
ObjectPascal
619 lines
14 KiB
ObjectPascal
{****************************************************************}
|
|
{ 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;
|
|
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;
|
|
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 := @obj.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 := @cla.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 := @cla.test_virtual_self;
|
|
end;
|
|
|
|
|
|
function get_class_method_normal : tclassmethod;
|
|
begin
|
|
get_class_method_normal := @cla.test_normal;
|
|
end;
|
|
{
|
|
function get_class_method_static : tclassmethod;
|
|
begin
|
|
get_class_method_static := @cla.test_static;
|
|
end;}
|
|
|
|
function get_class_method_virtual : tclassmethod;
|
|
begin
|
|
get_class_method_virtual := @cla.test_virtual;
|
|
end;
|
|
|
|
{****************************************************************************************************}
|
|
|
|
constructor tsimpleobject.init;
|
|
begin
|
|
end;
|
|
|
|
procedure tsimpleobject.test_normal(x: byte);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;
|
|
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:=@obj.test_virtual;
|
|
obj_method(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
obj_method:=@obj.test_virtual;
|
|
obj_method(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
value_u8bit := RESULT_U8BIT;
|
|
obj_method:=@obj.test_normal;
|
|
obj_method(value_u8bit);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
value_u8bit := RESULT_U8BIT;
|
|
obj_method:=@obj.test_virtual;
|
|
obj_method(value_u8bit);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
value_u8bit := RESULT_U8BIT;
|
|
obj_method:=@obj.test_normal;
|
|
obj_method(value_u8bit);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
|
|
If failed then
|
|
fail
|
|
else
|
|
WriteLn('Passed!');
|
|
|
|
{****************************************************************************************************}
|
|
Write('Testing class method variable call (LOC_REGISTER) ..');
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
failed := false;
|
|
|
|
tclassmethod(get_class_method_normal)(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
|
|
tclassmethod(get_class_method_virtual)(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
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 := @cla.test_normal;
|
|
cla_method(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
|
|
cla_method := @cla.test_virtual;
|
|
cla_method(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
cla_method := @cla.test_virtual;
|
|
cla_method(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
{ cla_method := @cla.test_static;
|
|
cla_method(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;}
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
|
|
cla_method_self := @cla.test_normal_self;
|
|
cla_method_self(cla, RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
|
|
cla_method_self := @cla.test_virtual_self;
|
|
cla_method_self(cla,RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
cla_method_self := @cla.test_virtual_self;
|
|
cla_method_self(cla, RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;
|
|
|
|
clear_globals;
|
|
clear_values;
|
|
|
|
{ cla_method := @cla.test_static;
|
|
cla_method(RESULT_U8BIT);
|
|
if global_u8bit <> RESULT_U8BIT then
|
|
failed := true;}
|
|
|
|
If failed then
|
|
fail
|
|
else
|
|
WriteLn('Passed!');
|
|
|
|
end.
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.4 2003-01-16 22:14:49 peter
|
|
* fixed wrong methodpointer loads
|
|
|
|
Revision 1.3 2002/12/29 15:30:55 peter
|
|
* updated for 1.1 compiler that does not allow calling conventions
|
|
for constructor/destructor
|
|
|
|
Revision 1.2 2002/09/07 15:40:54 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
Revision 1.1 2002/05/05 13:58:50 carl
|
|
+ finished procedural variable testsuit
|
|
+ finished method testsuit
|
|
|
|
}
|