paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-15 10:09:15 +02:00
Code Issues Packages Projects Releases Wiki Activity

* removed po_containsself tests

Browse Source
This commit is contained in:
peter 2003-05-15 20:34:29 +00:00
parent ae6e6aa136
commit 6ec7a2ffa2
8 changed files with 152 additions and 604 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
tests/test/cg/tcalpvr1.pp
View File

@ -43,22 +43,16 @@ type
procedure test_normal(x: byte);
class procedure test_static(x: byte);
procedure test_virtual(x: byte);virtual;
procedure test_normal_self(self : tsimpleclass; x: byte); message 0;
class procedure test_static_self(self : tsimpleclass; x: byte); message 1;
procedure test_virtual_self(self : tsimpleclass; x: byte);virtual;message 2;
end;
tobjectmethod = procedure (x: byte) of object ;
tclassmethod = procedure (x: byte) of object;
{ used for testing pocontainsself explicit parameter }
tclassmethodself = procedure (self : tsimpleclass; x: byte) of object;
var
proc : troutine;
func : troutineresult;
obj_method : tobjectmethod;
cla_method : tclassmethod;
cla_method_self : tclassmethodself;
global_s32bit : longint;
global_s64bit : int64;
global_u8bit : byte;
@ -137,26 +131,6 @@ var
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;
@ -214,22 +188,6 @@ var
global_u8bit := x;
end;
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);
begin
global_u8bit := x;
end;
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);
begin
global_u8bit := x;
end;
procedure tsimpleclass.test_virtual_self(self : tsimpleclass; x: byte);
begin
global_u8bit := x;
end;
var
failed : boolean;
Begin
@ -492,6 +450,12 @@ Begin
if global_u8bit <> RESULT_U8BIT then
failed := true;
If failed then
fail
else
WriteLn('Passed!');
clear_globals;
clear_values;
@ -503,23 +467,6 @@ Begin
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)...');
@ -527,7 +474,6 @@ Begin
clear_values;
failed := false;
cla_method := @cla.test_normal;
cla_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
@ -562,31 +508,6 @@ Begin
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
@ -601,7 +522,10 @@ end.
{
$Log$
Revision 1.5 2003-01-16 22:14:49 peter
Revision 1.6 2003-05-15 20:34:29 peter
* removed po_containsself tests
Revision 1.5 2003/01/16 22:14:49 peter
* fixed wrong methodpointer loads
Revision 1.4 2002/09/07 15:40:54 peter

79
tests/test/cg/tcalpvr2.pp
View File

@ -43,22 +43,16 @@ type
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;
@ -137,12 +131,6 @@ var
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;
@ -151,12 +139,6 @@ var
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;
@ -214,21 +196,6 @@ var
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;
@ -500,22 +467,6 @@ Begin
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
@ -562,31 +513,6 @@ Begin
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
@ -601,7 +527,10 @@ end.
{
$Log$
Revision 1.4 2003-01-16 22:14:49 peter
Revision 1.5 2003-05-15 20:34:29 peter
* removed po_containsself tests
Revision 1.4 2003/01/16 22:14:49 peter
* fixed wrong methodpointer loads
Revision 1.3 2003/01/05 18:21:30 peter

140
tests/test/cg/tcalpvr3.pp
View File

@ -12,7 +12,7 @@
{ DEFINES: }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() , it }
{ verifies procedural variables for cdecl }
{ verifies procedural variables for cdecl }
{ calling conventions. }
{****************************************************************}
program tcalpvr3;
@ -35,27 +35,24 @@ type
constructor init;
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;
procedure test_normal(x: byte);cdecl;
class procedure test_static(x: byte);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(x: byte);virtual;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;
@ -124,12 +121,14 @@ var
get_object_method_normal := @obj.test_normal;
end;
{ class access }
function get_class_method_normal_self : tclassmethodself;
function get_object_type_method_virtual : tobjectmethod;
begin
get_class_method_normal_self := @cla.test_normal_self;
get_object_type_method_virtual := @obj.test_virtual;
end;
function get_object_method_virtual : tobjectmethod;
begin
get_object_method_virtual := @obj.test_virtual;
end;
{
@ -140,7 +139,6 @@ var
end;
}
function get_class_method_normal : tclassmethod;
begin
get_class_method_normal := @cla.test_normal;
@ -151,6 +149,10 @@ var
get_class_method_static := @cla.test_static;
end;}
function get_class_method_virtual : tclassmethod;
begin
get_class_method_virtual := @cla.test_virtual;
end;
{****************************************************************************************************}
@ -168,6 +170,11 @@ var
global_u8bit := x;
end;
procedure tsimpleobject.test_virtual(x: byte);cdecl;
begin
global_u8bit := x;
end;
{****************************************************************************************************}
constructor tsimpleclass.create;
begin
@ -184,18 +191,11 @@ var
global_u8bit := x;
end;
procedure tsimpleclass.test_normal_self(self : tsimpleclass; x: byte);cdecl;
procedure tsimpleclass.test_virtual(x: byte);cdecl;
begin
global_u8bit := x;
end;
class procedure tsimpleclass.test_static_self(self : tsimpleclass; x: byte);cdecl;
begin
global_u8bit := x;
end;
var
failed : boolean;
@ -344,6 +344,19 @@ Begin
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;
@ -353,6 +366,22 @@ Begin
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
@ -373,12 +402,36 @@ Begin
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;
@ -409,7 +462,8 @@ Begin
clear_globals;
clear_values;
tclassmethodself(get_class_method_normal_self)(cla,RESULT_U8BIT);
tclassmethod(get_class_method_virtual)(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
failed := true;
@ -430,6 +484,22 @@ Begin
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;
@ -443,15 +513,6 @@ Begin
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 := @cla.test_static;
cla_method(RESULT_U8BIT);
if global_u8bit <> RESULT_U8BIT then
@ -466,21 +527,14 @@ end.
{
$Log$
Revision 1.7 2003-01-16 22:14:49 peter
Revision 1.8 2003-05-15 20:34:29 peter
* removed po_containsself tests
Revision 1.4 2003/01/16 22:14:49 peter
* fixed wrong methodpointer loads
Revision 1.6 2002/10/29 20:44:31 carl
* updated with corrects testing (removed cdecl in constructors)
Revision 1.5 2002/10/21 19:21:28 carl
* only test on version 1.1 +
Revision 1.4 2002/10/21 19:07:08 carl
+ reinstate test
- remove virtual method calls
Revision 1.3 2002/10/21 08:03:14 pierre
* added %FAIL because cdecl and virtual are not compatible
Revision 1.3 2003/01/05 18:21:30 peter
* removed more conflicting calling directives
Revision 1.2 2002/09/07 15:40:54 peter
* old logs removed and tabs fixed

88
tests/test/cg/tcalpvr4.pp
View File

@ -12,10 +12,10 @@
{ DEFINES: }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() , it }
{ verifies procedural variables for popstack }
{ verifies procedural variables for popstack }
{ calling conventions. }
{****************************************************************}
program tcalpvr4;
program tcalpvr3;
{$MODE OBJFPC}
{$STATIC ON}
{$R+}
@ -43,22 +43,16 @@ type
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;
@ -137,12 +131,6 @@ var
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;
@ -151,12 +139,6 @@ var
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;
@ -214,21 +196,6 @@ var
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;
@ -500,22 +467,6 @@ Begin
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
@ -562,31 +513,6 @@ Begin
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
@ -601,12 +527,14 @@ end.
{
$Log$
Revision 1.4 2003-01-16 22:14:49 peter
Revision 1.5 2003-05-15 20:34:29 peter
* removed po_containsself tests
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.3 2003/01/05 18:21:30 peter
* removed more conflicting calling directives
Revision 1.2 2002/09/07 15:40:54 peter
* old logs removed and tabs fixed

88
tests/test/cg/tcalpvr5.pp
View File

@ -12,10 +12,10 @@
{ DEFINES: }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() , it }
{ verifies procedural variables for safecall }
{ verifies procedural variables for safecall }
{ calling conventions. }
{****************************************************************}
program tcalpvr5;
program tcalpvr3;
{$MODE OBJFPC}
{$STATIC ON}
{$R+}
@ -43,22 +43,16 @@ type
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;
@ -137,12 +131,6 @@ var
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;
@ -151,12 +139,6 @@ var
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;
@ -214,21 +196,6 @@ var
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;
@ -500,22 +467,6 @@ Begin
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
@ -562,31 +513,6 @@ Begin
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
@ -601,12 +527,14 @@ end.
{
$Log$
Revision 1.4 2003-01-16 22:14:49 peter
Revision 1.5 2003-05-15 20:34:29 peter
* removed po_containsself tests
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.3 2003/01/05 18:21:30 peter
* removed more conflicting calling directives
Revision 1.2 2002/09/07 15:40:54 peter
* old logs removed and tabs fixed

85
tests/test/cg/tcalpvr6.pp
View File

@ -12,10 +12,10 @@
{ DEFINES: }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() , it }
{ verifies procedural variables for register }
{ verifies procedural variables for register }
{ calling conventions. }
{****************************************************************}
program tcalpvr6;
program tcalpvr3;
{$MODE OBJFPC}
{$STATIC ON}
{$R+}
@ -43,22 +43,16 @@ type
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;
@ -137,12 +131,6 @@ var
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;
@ -151,12 +139,6 @@ var
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;
@ -214,21 +196,6 @@ var
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;
@ -500,22 +467,6 @@ Begin
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
@ -562,31 +513,6 @@ Begin
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
@ -601,13 +527,16 @@ end.
{
$Log$
Revision 1.4 2003-01-16 22:14:49 peter
Revision 1.5 2003-05-15 20:34:29 peter
* removed po_containsself tests
Revision 1.4 2003/01/16 22:14:49 peter
* fixed wrong methodpointer loads
Revision 1.3 2003/01/05 18:21:30 peter
* removed more conflicting calling directives
Revision 1.2 2002/09/07 15:40:55 peter
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

90
tests/test/cg/tcalpvr7.pp
View File

@ -12,10 +12,10 @@
{ DEFINES: }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() , it }
{ verifies procedural variables for stdcall }
{ verifies procedural variables for stdcall }
{ calling conventions. }
{****************************************************************}
program tcalpvr7;
program tcalpvr3;
{$MODE OBJFPC}
{$STATIC ON}
{$R+}
@ -43,22 +43,16 @@ type
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;
@ -137,12 +131,6 @@ var
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;
@ -151,12 +139,6 @@ var
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;
@ -214,21 +196,6 @@ var
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;
@ -500,22 +467,6 @@ Begin
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
@ -562,31 +513,6 @@ Begin
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
@ -601,14 +527,16 @@ end.
{
$Log$
Revision 1.4 2003-01-16 22:14:49 peter
Revision 1.5 2003-05-15 20:34:29 peter
* removed po_containsself tests
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.3 2003/01/05 18:21:30 peter
* removed more conflicting calling directives
Revision 1.2 2002/09/07 15:40:55 peter
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

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

@ -12,10 +12,10 @@
{ DEFINES: }
{****************************************************************}
{ REMARKS: This tests a subset of the secondcalln() , it }
{ verifies procedural variables for saveregisters }
{ verifies procedural variables for saveregisters }
{ calling conventions. }
{****************************************************************}
program tcalpvr8;
program tcalpvr3;
{$MODE OBJFPC}
{$STATIC ON}
{$R+}
@ -43,22 +43,16 @@ type
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;
@ -137,12 +131,6 @@ var
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;
@ -151,12 +139,6 @@ var
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;
@ -214,21 +196,6 @@ var
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;
@ -500,22 +467,6 @@ Begin
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
@ -562,31 +513,6 @@ Begin
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
@ -601,14 +527,16 @@ end.
{
$Log$
Revision 1.4 2003-01-16 22:14:49 peter
Revision 1.5 2003-05-15 20:34:29 peter
* removed po_containsself tests
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.3 2003/01/05 18:21:30 peter
* removed more conflicting calling directives
Revision 1.2 2002/09/07 15:40:55 peter
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