paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-01 05:39:30 +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; program tcall;
{$mode objfpc} {$ifdef fpc}{$mode objfpc}{$endif}
uses sysutils; uses SysUtils;
{ {
class: class:
class constructor class constructor
1a - success 1a - success
1b - failure 1b - failure
2 class destructor 2 class destructor
3 class method 3 class method
4 virtual method 4 virtual method
5 abstract method 5 abstract method
6 static method 6 static method
object: object:
object constructor object constructor
7a - success 7a - success
7b - failure 7b - failure
@ -43,15 +43,15 @@ standard:
11 function 11 function
12 procedure 12 procedure
13 procedure variable 13 procedure variable
modifiers: modifiers:
no parameters 1a 1b no parameters 1a 1b
parameters parameters
- const 1a - const 1a
- value 1a - value 1a
- variable 1a - variable 1a
- mixed 1a - mixed 1a
explicit self parameter explicit self parameter
operator directive operator directive
assembler directive assembler directive
@ -67,7 +67,7 @@ modifiers:
const const
GLOBAL_RESULT = $55; GLOBAL_RESULT = $55;
var var
globalresult : integer; globalresult : integer;
failed : boolean; failed : boolean;
@ -81,13 +81,14 @@ type
constructor create_const(const l:longint; const b: byte); constructor create_const(const l:longint; const b: byte);
constructor create_mixed(var a: byte; b: byte; var c: byte; const d: byte); constructor create_mixed(var a: byte; b: byte; var c: byte; const d: byte);
end; end;
tclass2 = class tclass2 = class
constructor create_none; { class constructor } constructor create_none; { class constructor }
public
b: array[1..20000000] of byte; b: array[1..20000000] of byte;
end; end;
constructor tclass1.create_none; constructor tclass1.create_none;
begin begin
Inherited create; Inherited create;
@ -106,27 +107,27 @@ type
Inherited create; Inherited create;
b:=GLOBAL_RESULT; b:=GLOBAL_RESULT;
end; end;
constructor tclass1.create_const(const l:longint; const b: byte); constructor tclass1.create_const(const l:longint; const b: byte);
begin begin
Inherited create; Inherited create;
globalresult := GLOBAL_RESULT; globalresult := GLOBAL_RESULT;
end; end;
constructor tclass1.create_mixed(var a: byte; b: byte; var c: byte; const d: byte); constructor tclass1.create_mixed(var a: byte; b: byte; var c: byte; const d: byte);
begin begin
Inherited create; Inherited create;
globalresult := GLOBAL_RESULT; globalresult := GLOBAL_RESULT;
end; end;
constructor tclass2.create_none; constructor tclass2.create_none;
begin begin
Inherited create; Inherited create;
globalresult:=GLOBAL_RESULT; globalresult:=GLOBAL_RESULT;
end; end;
procedure fail; procedure fail;
@ -152,66 +153,71 @@ var
l:longint; l:longint;
Begin Begin
{ reset test variables } { reset test variables }
globalresult := 0; globalresult := 0;
failed := false; failed := false;
{$ifdef fpc}
{ required to do correct testing...} { required to do correct testing...}
heaperror := @myheaperror; heaperror := @myheaperror;
{$endif fpc}
write('class constructor testing...'); write('class constructor testing...');
{ secondcalln : class constructor success } { secondcalln : class constructor success }
class_none:=tclass1.create_none; class_none:=tclass1.create_none;
if globalresult <> GLOBAL_RESULT then if globalresult <> GLOBAL_RESULT then
failed:= true; failed:= true;
globalresult := 0; globalresult := 0;
class_value:=tclass1.create_value(0,GLOBAL_RESULT); class_value:=tclass1.create_value(0,GLOBAL_RESULT);
if globalresult <> GLOBAL_RESULT then if globalresult <> GLOBAL_RESULT then
failed:= true; failed:= true;
globalresult := 0; globalresult := 0;
b:=0; b:=0;
class_var:=tclass1.create_var(l,b); class_var:=tclass1.create_var(l,b);
globalresult:=b; globalresult:=b;
if globalresult <> GLOBAL_RESULT then if globalresult <> GLOBAL_RESULT then
failed:= true; failed:= true;
globalresult := 0; globalresult := 0;
b:=GLOBAL_RESULT; b:=GLOBAL_RESULT;
class_const:=tclass1.create_const(l,b); class_const:=tclass1.create_const(l,b);
if globalresult <> GLOBAL_RESULT then if globalresult <> GLOBAL_RESULT then
failed:= true; failed:= true;
globalresult := 0; globalresult := 0;
b:=0; b:=0;
a:=0; a:=0;
c:=0; c:=0;
d:=GLOBAL_RESULT; 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 if globalresult <> GLOBAL_RESULT then
failed:= true; failed:= true;
globalresult := 0; globalresult := 0;
{ secondcalln : class constructor failure } { secondcalln : class constructor failure }
try try
class_none_fail:=tclass2.create_none; class_none_fail:=tclass2.create_none;
except except
on EOutOfMemory do globalresult:=GLOBAL_RESULT; on EOutOfMemory do globalresult:=GLOBAL_RESULT;
end; end;
if globalresult <> GLOBAL_RESULT then if globalresult <> GLOBAL_RESULT then
failed:= true; failed:= true;
if failed then if failed then
fail fail
else else
WriteLn('Passed!'); WriteLn('Passed!');
end. end.
{ {
$Log$ $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 + secondcalln() : unfinished
} }