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

* fix for non-fpc compilers

Browse Source
This commit is contained in:
peter 2002-04-02 17:05:17 +00:00
parent abf3bcc2e7
commit 5bdcf72f80
1 changed files with 43 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
tests/test/cg/tcall1.pp
View File

@ -19,20 +19,20 @@
{****************************************************************}
program tcall;
{$mode objfpc}
uses sysutils;
{$ifdef fpc}{$mode objfpc}{$endif}
uses SysUtils;
{
class:
class constructor
1a - success
1b - failure
1a - success
1b - failure
2 class destructor
3 class method
4 virtual method
5 abstract method
6 static method
object:
object:
object constructor
7a - success
7b - failure
@ -43,15 +43,15 @@ standard:
11 function
12 procedure
13 procedure variable
modifiers:
no parameters 1a 1b
no parameters 1a 1b
parameters
- const 1a
- value 1a
- variable 1a
- mixed 1a
- mixed 1a
explicit self parameter
operator directive
assembler directive
@ -67,7 +67,7 @@ modifiers:
const
GLOBAL_RESULT = $55;
var
globalresult : integer;
failed : boolean;
@ -81,13 +81,14 @@ type
constructor create_const(const l:longint; const b: byte);
constructor create_mixed(var a: byte; b: byte; var c: byte; const d: byte);
end;
tclass2 = class
constructor create_none; { class constructor }
public
b: array[1..20000000] of byte;
end;
constructor tclass1.create_none;
begin
Inherited create;
@ -106,27 +107,27 @@ type
Inherited create;
b:=GLOBAL_RESULT;
end;
constructor tclass1.create_const(const l:longint; const b: byte);
begin
Inherited create;
globalresult := GLOBAL_RESULT;
end;
constructor tclass1.create_mixed(var a: byte; b: byte; var c: byte; const d: byte);
begin
Inherited create;
globalresult := GLOBAL_RESULT;
end;
constructor tclass2.create_none;
begin
Inherited create;
globalresult:=GLOBAL_RESULT;
end;
procedure fail;
@ -152,66 +153,71 @@ var
l:longint;
Begin
{ reset test variables }
globalresult := 0;
globalresult := 0;
failed := false;
{$ifdef fpc}
{ required to do correct testing...}
heaperror := @myheaperror;
heaperror := @myheaperror;
{$endif fpc}
write('class constructor testing...');
{ secondcalln : class constructor success }
class_none:=tclass1.create_none;
{ secondcalln : class constructor success }
class_none:=tclass1.create_none;
if globalresult <> GLOBAL_RESULT then
failed:= true;
globalresult := 0;
class_value:=tclass1.create_value(0,GLOBAL_RESULT);
globalresult := 0;
class_value:=tclass1.create_value(0,GLOBAL_RESULT);
if globalresult <> GLOBAL_RESULT then
failed:= true;
globalresult := 0;
globalresult := 0;
b:=0;
class_var:=tclass1.create_var(l,b);
class_var:=tclass1.create_var(l,b);
globalresult:=b;
if globalresult <> GLOBAL_RESULT then
failed:= true;
globalresult := 0;
globalresult := 0;
b:=GLOBAL_RESULT;
class_const:=tclass1.create_const(l,b);
class_const:=tclass1.create_const(l,b);
if globalresult <> GLOBAL_RESULT then
failed:= true;
globalresult := 0;
globalresult := 0;
b:=0;
a:=0;
c:=0;
d:=GLOBAL_RESULT;
class_mixed:=tclass1.create_mixed(a,b,c,d);
class_mixed:=tclass1.create_mixed(a,b,c,d);
if globalresult <> GLOBAL_RESULT then
failed:= true;
globalresult := 0;
globalresult := 0;
{ secondcalln : class constructor failure }
try
class_none_fail:=tclass2.create_none;
try
class_none_fail:=tclass2.create_none;
except
on EOutOfMemory do globalresult:=GLOBAL_RESULT;
end;
end;
if globalresult <> GLOBAL_RESULT then
failed:= true;
if failed then
fail
else
WriteLn('Passed!');
end.
{
$Log$
Revision 1.1 2002-03-30 23:19:16 carl
Revision 1.2 2002-04-02 17:05:17 peter
* fix for non-fpc compilers
Revision 1.1 2002/03/30 23:19:16 carl
+ secondcalln() : unfinished
}