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

+ mre tests for cg testuit

Browse Source
This commit is contained in:
carl 2002-08-10 08:27:43 +00:00
parent f94cec7ddb
commit 589f06c18f
11 changed files with 1274 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
tests/test/cg/tassign1.pp Normal file
View File

@ -0,0 +1,77 @@
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondassign() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{ Tests the sortstring assignment. }
{****************************************************************}
program tassign1;
{$ifdef fpc}
{$mode objfpc}
{$endif}
const
RESULT_STRING = 'Hello world';
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
function getc : char;
begin
getc := 'a';
end;
var
failed : boolean;
s: shortstring;
c: char;
Begin
Write('secondassign shortstring node testing...');
failed := false;
{ constant string }
s:=RESULT_STRING;
if s<>RESULT_STRING then
failed := true;
{ empty constant string, small optim. }
s:='';
if s<>'' then
failed := true;
{ constant character }
s:='a';
if s<>'a' then
failed := true;
{ non-constant character }
c:='a';
s:=c;
if s<>'a' then
failed := true;
s:=getc;
if s<>'a' then
failed := true;
if failed then
fail
else
WriteLn('Success!');
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:43 carl
+ mre tests for cg testuit
}

211
tests/test/cg/tassign2.pp Normal file
View File

@ -0,0 +1,211 @@
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondassign() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program tassign2;
{$ifdef fpc}
{$warning Will only work on 32-bit cpu's}
{$mode objfpc}
{$endif}
const
RESULT_STRING = 'Hello world';
RESULT_S64BIT = -12;
RESULT_S32BIT = -124356;
RESULT_U32BIT = 654321;
RESULT_U8BIT = $55;
RESULT_S16BIT = -12124;
RESULT_REAL = 12.12;
{ adjusts the size of the bigrecord }
MAX_INDEX = 7;
type
{
the size of this record should *at least* be the size
of a natural register for the target processor
}
tbigrecord = record
x : cardinal;
y : cardinal;
z : array[0..MAX_INDEX] of byte;
end;
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
function getresults64bit: int64;
begin
getresults64bit := RESULT_S64BIT;
end;
function getresults32bit : longint;
begin
getresults32bit := RESULT_S32BIT;
end;
function getresultu8bit : byte;
begin
getresultu8bit := RESULT_U8BIT;
end;
function getresults16bit : smallint;
begin
getresults16bit := RESULT_S16BIT;
end;
function getresultreal : real;
begin
getresultreal := RESULT_REAL;
end;
var
failed : boolean;
s64bit : int64;
s32bit : longint;
s16bit : smallint;
u8bit : byte;
boolval : boolean;
real_val : real;
bigrecord1, bigrecord2 : tbigrecord;
i: integer;
Begin
WriteLn('secondassign node testing.');
failed := false;
{ possibilities : left : any, right : LOC_REFERENCE, LOC_REGISTER,
LOC_FPUREGISTER, LOC_CONSTANT, LOC_JUMP and LOC_FLAGS }
Write('left : LOC_REFERENCE, right : LOC_CONSTANT tests..');
s64bit := RESULT_S64BIT;
if s64bit <> RESULT_S64BIT then
failed := true;
s32bit := RESULT_S32BIT;
if s32bit <> RESULT_S32BIT then
failed := true;
if failed then
fail
else
WriteLn('Success!');
Write('left : LOC_REFERENCE, right : LOC_REGISTER tests..');
failed := false;
s64bit := getresults64bit;
if s64bit <> RESULT_S64BIT then
failed := true;
s32bit := getresults32bit;
if s32bit <> RESULT_S32BIT then
failed := true;
s16bit := getresults16bit;
if s16bit <> RESULT_S16BIT then
failed := true;
u8bit := getresultu8bit;
if u8bit <> RESULT_U8BIT then
failed := true;
if failed then
fail
else
WriteLn('Success!');
Write('left : LOC_REFERENCE, right : LOC_FPUREGISTER tests..');
failed := false;
real_val := getresultreal;
if trunc(real_val) <> trunc(RESULT_REAL) then
failed := true;
if failed then
fail
else
WriteLn('Success!');
Write('left : LOC_REFERENCE, right : LOC_REFERENCE tests..');
failed := false;
bigrecord1.x := RESULT_U32BIT;
bigrecord1.y := RESULT_U32BIT;
for i:=0 to MAX_INDEX do
bigrecord1.z[i] := RESULT_U8BIT;
fillchar(bigrecord2, sizeof(bigrecord2),#0);
bigrecord2 := bigrecord1;
if bigrecord2.x <> RESULT_U32BIT then
failed := true;
if bigrecord2.y <> RESULT_U32BIT then
failed := true;
for i:=0 to MAX_INDEX do
begin
if bigrecord2.z[i] <> RESULT_U8BIT then
begin
failed := true;
break;
end;
end;
if failed then
fail
else
WriteLn('Success!');
Write('left : LOC_REFERENCE, right : LOC_JUMP tests (32-bit cpus only!)..');
{!!!!! This test will only work on 32-bit CPU's probably, on 64-bit CPUs
the location should be in LOC_FLAGS
}
failed := false;
s64bit := RESULT_S64BIT;
boolval := s64bit = RESULT_S64BIT;
if boolval = FALSE then
failed := true;
if failed then
fail
else
WriteLn('Success!');
Write('left : LOC_REFERENCE, right : LOC_FLAGS tests..');
failed := false;
s32bit := RESULT_S32BIT;
boolval := s32bit = RESULT_S32BIT;
if boolval = FALSE then
failed := true;
if failed then
fail
else
WriteLn('Success!');
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:43 carl
+ mre tests for cg testuit
}

193
tests/test/cg/tcnvint4.pp Normal file
View File

@ -0,0 +1,193 @@
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{****************************************************************}
{ NODE TESTED : secondtypeconvert() -> second_int_to_real }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondcalln() }
{ secondinline() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{****************************************************************}
{ REMARKS: Tests integer to real conversion }
{ This routine assumes that there is a type conversion }
{ from all types to s32bit, u32bit or s64bit before conversion }
{ to a real. }
{****************************************************************}
program tcnvint4;
{$ifdef VER70}
{$define tp}
{$endif}
{$R-}
{$ifdef tp}
type
smallint = integer;
{$endif}
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
const
RESULT_S64BIT = 101234;
RESULT_S32BIT = -1000000;
RESULT_U32BIT = 2000000;
RESULT_S16BIT = -12123;
RESULT_U16BIT = 12123;
RESULT_U8BIT = 247;
RESULT_S8BIT = -123;
{$ifndef tp}
function gets64bit : int64;
begin
gets64bit := RESULT_S64BIT;
end;
{$endif}
function gets32bit : longint;
begin
gets32bit := RESULT_S32BIT;
end;
function gets16bit : smallint;
begin
gets16bit := RESULT_S16BIT;
end;
function gets8bit : shortint;
begin
gets8bit := RESULT_S8BIT;
end;
function getu8bit : byte;
begin
getu8bit := RESULT_U8BIT;
end;
function getu16bit : word;
begin
getu16bit := RESULT_U16BIT;
end;
function getu32bit : longint;
begin
getu32bit := RESULT_U32BIT;
end;
var
s32bit : longint;
failed : boolean;
s16bit : smallint;
s8bit : shortint;
u8bit : byte;
u16bit : word;
{$ifndef tp}
s64bit : int64;
u32bit : cardinal;
{$endif}
result_val : real;
begin
{ left : LOC_REFERENCE }
Write('second_int_to_real (left : LOC_REFERENCE)...');
s64bit := RESULT_S64BIT;
failed := false;
result_val := s64bit;
if trunc(result_val) <> RESULT_S64BIT then
failed:=true;
s32bit := RESULT_S32BIT;
result_val := s32bit;
if trunc(result_val) <> RESULT_S32BIT then
failed:=true;
u32bit := RESULT_U32BIT;
result_val := u32bit;
if trunc(result_val) <> RESULT_U32BIT then
failed:=true;
s16bit := RESULT_S16BIT;
result_val := s16bit;
if trunc(result_val) <> RESULT_S16BIT then
failed:=true;
u16bit := RESULT_U16BIT;
result_val := u16bit;
if trunc(result_val) <> RESULT_U16BIT then
failed:=true;
s8bit := RESULT_S8BIT;
result_val := s8bit;
if trunc(result_val) <> RESULT_S8BIT then
failed:=true;
u8bit := RESULT_U8BIT;
result_val := u8bit;
if trunc(result_val) <> RESULT_U8BIT then
failed:=true;
if failed then
fail
else
WriteLn('Passed!');
Write('second_int_to_real (left : LOC_REGISTER)...');
failed := false;
result_val := gets64bit;
if trunc(result_val) <> RESULT_S64BIT then
failed:=true;
result_val := gets32bit;
if trunc(result_val) <> RESULT_S32BIT then
failed:=true;
result_val := getu32bit;
if trunc(result_val) <> RESULT_U32BIT then
failed:=true;
result_val := getu8bit;
if trunc(result_val) <> RESULT_u8BIT then
failed:=true;
result_val := gets8bit;
if trunc(result_val) <> RESULT_s8BIT then
failed:=true;
result_val := gets16bit;
if trunc(result_val) <> RESULT_S16BIT then
failed:=true;
result_val := getu16bit;
if trunc(result_val) <> RESULT_U16BIT then
failed:=true;
if failed then
fail
else
WriteLn('Passed!');
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:43 carl
+ mre tests for cg testuit
}

319
tests/test/cg/tfuncret.pp Normal file
View File

@ -0,0 +1,319 @@
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondfuncret() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program tfuncret;
{$ifdef ver70}
{$define tp}
{$endif}
const
{ adjusts the size of the bigrecord }
MAX_INDEX = 7;
RESULT_S64BIT = -12;
RESULT_S32BIT = -124356;
RESULT_U32BIT = 654321;
RESULT_U8BIT = $55;
type
{
the size of this record should *at least* be the size
of a natural register for the target processor
}
tbigrecord = record
x : cardinal;
y : cardinal;
z : array[0..MAX_INDEX] of byte;
end;
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
{****************************************************************}
{ SIMPLE CASE }
{****************************************************************}
function getresult_simple_s64bit: int64;
var
s64bit : int64;
i: integer;
begin
getresult_simple_s64bit := 0;
s64bit:=RESULT_S64BIT;
getresult_simple_s64bit := s64bit;
end;
function getresult_simple_s32bit: longint;
var
s32bit : longint;
i: longint;
begin
getresult_simple_s32bit := 0;
i:=1;
i:=i*RESULT_S32BIT div i;
s32bit:=i;
getresult_simple_s32bit := s32bit;
end;
function getresult_simple_bigrecord : tbigrecord;
var
localbigrecord : tbigrecord;
i: integer;
begin
localbigrecord.x := RESULT_U32BIT;
localbigrecord.y := RESULT_U32BIT;
for i:=0 to MAX_INDEX do
localbigrecord.z[i] := RESULT_U8BIT;
getresult_simple_bigrecord := localbigrecord;
end;
{****************************************************************}
{ WITH NESTING }
{****************************************************************}
function getresult_nested_s64bit: int64;
procedure nested_one;
var
s64bit : int64;
i: longint;
begin
getresult_nested_s64bit := 0;
s64bit:=RESULT_S64BIT;
getresult_nested_s64bit := s64bit;
end;
begin
nested_one;
end;
function getresult_nested_s32bit: longint;
procedure nested_one;
var
s32bit : longint;
i: longint;
begin
getresult_nested_s32bit := 0;
i:=1;
i:=i*RESULT_S32BIT div i;
s32bit:=i;
getresult_nested_s32bit := s32bit;
end;
begin
nested_one;
end;
function getresult_nested_bigrecord : tbigrecord;
procedure nested_one;
var
localbigrecord : tbigrecord;
i: longint;
begin
localbigrecord.x := RESULT_U32BIT;
localbigrecord.y := RESULT_U32BIT;
for i:=0 to MAX_INDEX do
localbigrecord.z[i] := RESULT_U8BIT;
getresult_nested_bigrecord := localbigrecord;
end;
begin
nested_one;
end;
{****************************************************************}
{ WITH COMPLEX NESTING }
{****************************************************************}
function getresult_nested_complex_s64bit: int64;
procedure nested_one;
var
s64bit : int64;
i: integer;
function nested_two: int64;
begin
nested_two:=0;
getresult_nested_complex_s64bit := 0;
s64bit:=RESULT_S64BIT;
getresult_nested_complex_s64bit := s64bit;
end;
begin
nested_two;
end;
begin
nested_one;
end;
function getresult_nested_complex_s32bit: longint;
procedure nested_one;
var
s32bit : longint;
i: longint;
function nested_two: longint;
begin
nested_two := 0;
getresult_nested_complex_s32bit := 0;
i:=1;
i:=i*RESULT_S32BIT div i;
s32bit:=i;
getresult_nested_complex_s32bit := s32bit;
end;
begin
nested_two;
end;
begin
nested_one;
end;
function getresult_nested_complex_bigrecord : tbigrecord;
procedure nested_one;
var
localbigrecord : tbigrecord;
function nested_two : tbigrecord;
var
i : integer;
begin
nested_two := localbigrecord;
localbigrecord.x := RESULT_U32BIT;
localbigrecord.y := RESULT_U32BIT;
for i:=0 to MAX_INDEX do
localbigrecord.z[i] := RESULT_U8BIT;
getresult_nested_complex_bigrecord := localbigrecord;
end;
begin
nested_two;
end;
begin
nested_one;
end;
var
failed : boolean;
bigrecord : tbigrecord;
i: integer;
Begin
Write('secondfuncret simple case tests...');
failed := false;
if getresult_simple_s64bit <> RESULT_S64BIT then
failed := true;
if getresult_simple_s32bit <> RESULT_S32BIT then
failed := true;
bigrecord := getresult_simple_bigrecord;
if bigrecord.x <> RESULT_U32BIT then
failed := true;
if bigrecord.y <> RESULT_U32BIT then
failed := true;
for i:=0 to MAX_INDEX do
begin
if bigrecord.z[i] <> RESULT_U8BIT then
begin
failed := true;
break;
end;
end;
if failed then
fail
else
WriteLn('Success!');
Write('secondfuncret simple nesting case tests...');
failed := false;
if getresult_nested_s64bit <> RESULT_S64BIT then
failed := true;
if getresult_nested_s32bit <> RESULT_S32BIT then
failed := true;
bigrecord := getresult_nested_bigrecord;
if bigrecord.x <> RESULT_U32BIT then
failed := true;
if bigrecord.y <> RESULT_U32BIT then
failed := true;
for i:=0 to MAX_INDEX do
begin
if bigrecord.z[i] <> RESULT_U8BIT then
begin
failed := true;
break;
end;
end;
if failed then
fail
else
WriteLn('Success!');
Write('secondfuncret complex nesting case tests...');
failed := false;
if getresult_nested_complex_s64bit <> RESULT_S64BIT then
failed := true;
if getresult_nested_complex_s32bit <> RESULT_S32BIT then
failed := true;
bigrecord := getresult_nested_complex_bigrecord;
if bigrecord.x <> RESULT_U32BIT then
failed := true;
if bigrecord.y <> RESULT_U32BIT then
failed := true;
for i:=0 to MAX_INDEX do
begin
if bigrecord.z[i] <> RESULT_U8BIT then
begin
failed := true;
break;
end;
end;
if failed then
fail
else
WriteLn('Success!');
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:43 carl
+ mre tests for cg testuit
}

72
tests/test/cg/tloadvmt.pp Normal file
View File

@ -0,0 +1,72 @@
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondloadvmt() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program tloadvmt;
{$ifdef fpc}
{$mode objfpc}
{$endif}
const
RESULT_STRING = 'Hello world';
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TAObject)
b : longint;
s : shortstring;
constructor create(c: longint);
function getstring : shortstring;
end;
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
constructor tbobject.create(c:longint);
begin
taobject.create;
b:=c;
s:=RESULT_STRING;
end;
function tbobject.getstring : shortstring;
begin
getstring := s;
end;
var
bobj: TBobject;
i: integer;
l : longint;
Begin
i:=$7f;
Write('Secondloadvmt test...');
bobj:=TBobject.create(i);
if bobj.getstring <> RESULT_STRING then
fail
else
WriteLn('Success!');
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:43 carl
+ mre tests for cg testuit
}

64
tests/test/cg/traise1.pp Normal file
View File

@ -0,0 +1,64 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program traise1;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
constructor create(c: longint);
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
constructor tbobject.create(c:longint);
begin
inherited create;
b:=c;
end;
var
A: TAObject;
Begin
A:=TAobject.create;
raise A;
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:44 carl
+ mre tests for cg testuit
}

61
tests/test/cg/traise2.pp Normal file
View File

@ -0,0 +1,61 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program traise2;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
constructor create(c: longint);
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
constructor tbobject.create(c:longint);
begin
inherited create;
b:=c;
end;
Begin
raise TAobject.create;
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:44 carl
+ mre tests for cg testuit
}

65
tests/test/cg/traise3.pp Normal file
View File

@ -0,0 +1,65 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program traise3;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
constructor create(c: longint);
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
constructor tbobject.create(c:longint);
begin
inherited create;
b:=c;
end;
var
bobj: TBobject;
i: integer;
Begin
i:=$7f;
bobj := TBobject.create(i);
raise bobj;
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:44 carl
+ mre tests for cg testuit
}

64
tests/test/cg/traise4.pp Normal file
View File

@ -0,0 +1,64 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program traise4;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
constructor create(c: longint);
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
constructor tbobject.create(c:longint);
begin
inherited create;
b:=c;
end;
var
bobj: TBobject;
i: integer;
Begin
i:=$7f;
raise TBobject.create(i);
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:44 carl
+ mre tests for cg testuit
}

74
tests/test/cg/traise5.pp Normal file
View File

@ -0,0 +1,74 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program traise5;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
constructor create(c: longint);
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
constructor tbobject.create(c:longint);
begin
inherited create;
b:=c;
end;
procedure MyRoutine;
Begin
WriteLn('hello world!');
end;
var
bobj: TBobject;
i: integer;
Begin
i:=$7f;
{$ifdef ver1_0}
raise TBobject.create(i) at longint(@MyRoutine);
{$else}
raise TBobject.create(i) at @MyRoutine;
{$endif}
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:44 carl
+ mre tests for cg testuit
}

74
tests/test/cg/traise6.pp Normal file
View File

@ -0,0 +1,74 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program traise6;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
constructor create(c: longint);
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
constructor tbobject.create(c:longint);
begin
inherited create;
b:=c;
end;
procedure MyRoutine;
Begin
WriteLn('hello world!');
end;
var
bobj: TBobject;
i: integer;
Begin
i:=$7f;
{$ifdef ver1_0}
raise TBobject.create(i) at longint(@MyRoutine);
{$else}
raise TBobject.create(i) at @MyRoutine,$00000001;
{$endif}
end.
{
$Log$
Revision 1.1 2002-08-10 08:27:44 carl
+ mre tests for cg testuit
}