mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-19 00:39:34 +02:00
- removed tests, since safecall doesn't make sense in these contexts
git-svn-id: trunk@3659 -
This commit is contained in:
Jonas Maebe
parent
5225caeecd
commit
0083045c16
3
.gitattributes
vendored
3
.gitattributes
vendored
@ -5515,7 +5515,6 @@ tests/test/cg/tcalfun1.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalfun2.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalfun3.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalfun4.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalfun5.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalfun6.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalfun7.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalfun8.pp svneol=native#text/plain
|
||||
@ -5525,7 +5524,6 @@ tests/test/cg/tcalobj1.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalobj2.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalobj3.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalobj4.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalobj5.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalobj6.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalobj7.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalobj8.pp svneol=native#text/plain
|
||||
@ -5534,7 +5532,6 @@ tests/test/cg/tcalpvr1.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalpvr2.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalpvr3.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalpvr4.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalpvr5.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalpvr6.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalpvr7.pp svneol=native#text/plain
|
||||
tests/test/cg/tcalpvr8.pp svneol=native#text/plain
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,526 +0,0 @@
|
||||
{****************************************************************}
|
||||
{ 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 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);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;
|
||||
end;
|
||||
|
||||
tobjectmethod = procedure (x: byte) of object ;safecall;
|
||||
tclassmethod = procedure (x: byte) of object;safecall;
|
||||
|
||||
var
|
||||
proc : troutine;
|
||||
func : troutineresult;
|
||||
obj_method : tobjectmethod;
|
||||
cla_method : tclassmethod;
|
||||
global_s32bit : longint;
|
||||
global_s64bit : int64;
|
||||
global_u8bit : byte;
|
||||
value_s32bit : longint;
|
||||
value_u8bit : byte;
|
||||
obj : tsimpleobject;
|
||||
cla : tsimpleclass;
|
||||
|
||||
|
||||
|
||||
|
||||
procedure fail;
|
||||
begin
|
||||
WriteLn('Failed!');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
procedure clear_globals;
|
||||
begin
|
||||
global_s32bit := 0;
|
||||
global_u8bit := 0;
|
||||
global_s64bit := 0;
|
||||
end;
|
||||
|
||||
procedure clear_values;
|
||||
begin
|
||||
value_s32bit := 0;
|
||||
value_u8bit := 0;
|
||||
end;
|
||||
|
||||
|
||||
procedure testroutine(x: longint; y: byte);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;
|
||||
|
||||
{
|
||||
HOW CAN WE GET THIS ADDRESS???
|
||||
function get_class_method_static_self : tclassmethodself;
|
||||
begin
|
||||
get_class_method_static_self := @cla.test_static_self;
|
||||
end;
|
||||
}
|
||||
|
||||
function get_class_method_normal : tclassmethod;
|
||||
begin
|
||||
get_class_method_normal := @cla.test_normal;
|
||||
end;
|
||||
{
|
||||
function get_class_method_static : tclassmethod;
|
||||
begin
|
||||
get_class_method_static := @cla.test_static;
|
||||
end;}
|
||||
|
||||
function get_class_method_virtual : tclassmethod;
|
||||
begin
|
||||
get_class_method_virtual := @cla.test_virtual;
|
||||
end;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
constructor tsimpleobject.init;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure tsimpleobject.test_normal(x: byte);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;
|
||||
|
||||
|
||||
var
|
||||
failed : boolean;
|
||||
Begin
|
||||
{ setup variables }
|
||||
proc := @testroutine;
|
||||
func := @testroutineresult;
|
||||
obj.init;
|
||||
cla:=tsimpleclass.create;
|
||||
|
||||
{****************************************************************************************************}
|
||||
|
||||
Write('Testing procedure variable call (LOC_REGISTER)..');
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
failed := false;
|
||||
|
||||
{ parameters in LOC_CONSTANT, routine address in LOC_REGISTER }
|
||||
troutine(getroutine)(RESULT_S32BIT,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
if global_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
{ parameters in LOC_REFERENCE,routine address in LOC_REGISTER }
|
||||
value_s32bit := RESULT_S32BIT;
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
troutine(getroutine)(value_s32bit , value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
if global_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
|
||||
Write('Testing procedure variable call (LOC_REFERENCE)..');
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
failed := false;
|
||||
|
||||
{ parameters in LOC_CONSTANT, routine address in LOC_REGISTER }
|
||||
proc(RESULT_S32BIT,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
if global_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
{ parameters in LOC_REFERENCE,routine address in LOC_REGISTER }
|
||||
value_s32bit := RESULT_S32BIT;
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
proc(value_s32bit , value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
if global_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
{****************************************************************************************************}
|
||||
Write('Testing function variable call (LOC_REGISTER)..');
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
failed := false;
|
||||
|
||||
{ parameters in LOC_CONSTANT, routine address in LOC_REGISTER }
|
||||
global_s64bit := troutineresult(getroutineresult)(RESULT_S32BIT,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
if global_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
if global_s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
{ parameters in LOC_REFERENCE,routine address in LOC_REGISTER }
|
||||
value_s32bit := RESULT_S32BIT;
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
global_s64bit := troutineresult(getroutineresult)(value_s32bit , value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
if global_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
if global_s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
|
||||
Write('Testing function variable call (LOC_REFERENCE)..');
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
failed := false;
|
||||
|
||||
{ parameters in LOC_CONSTANT, routine address in LOC_REGISTER }
|
||||
global_s64bit := func(RESULT_S32BIT,RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
if global_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
if global_s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
{ parameters in LOC_REFERENCE,routine address in LOC_REGISTER }
|
||||
value_s32bit := RESULT_S32BIT;
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
global_s64bit := func(value_s32bit , value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
if global_s32bit <> RESULT_S32BIT then
|
||||
failed := true;
|
||||
if global_s64bit <> RESULT_S64BIT then
|
||||
failed := true;
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
{****************************************************************************************************}
|
||||
Write('Testing object method variable call (LOC_REGISTER) ..');
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
failed := false;
|
||||
|
||||
tobjectmethod(get_object_method_normal)(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tobjectmethod(get_object_type_method_virtual)(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
tobjectmethod(get_object_method_virtual)(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
tobjectmethod(get_object_method_normal)(value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
tobjectmethod(get_object_type_method_virtual)(value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
tobjectmethod(get_object_method_virtual)(value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
Write('Testing object method variable call (LOC_REFERENCE) ..');
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
failed := false;
|
||||
|
||||
obj_method:=@obj.test_normal;
|
||||
obj_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
obj_method:=@obj.test_virtual;
|
||||
obj_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
obj_method:=@obj.test_virtual;
|
||||
obj_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
obj_method:=@obj.test_normal;
|
||||
obj_method(value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
obj_method:=@obj.test_virtual;
|
||||
obj_method(value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
value_u8bit := RESULT_U8BIT;
|
||||
obj_method:=@obj.test_normal;
|
||||
obj_method(value_u8bit);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
{****************************************************************************************************}
|
||||
Write('Testing class method variable call (LOC_REGISTER) ..');
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
failed := false;
|
||||
|
||||
tclassmethod(get_class_method_normal)(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
tclassmethod(get_class_method_virtual)(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
Write('Testing class method variable call (LOC_REFERENCE)...');
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
failed := false;
|
||||
|
||||
|
||||
cla_method := @cla.test_normal;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
cla_method := @cla.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
cla_method := @cla.test_virtual;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
{ cla_method := @cla.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
clear_globals;
|
||||
clear_values;
|
||||
|
||||
|
||||
{ cla_method := @cla.test_static;
|
||||
cla_method(RESULT_U8BIT);
|
||||
if global_u8bit <> RESULT_U8BIT then
|
||||
failed := true;}
|
||||
|
||||
If failed then
|
||||
fail
|
||||
else
|
||||
WriteLn('Passed!');
|
||||
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user