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

* some tests from CEC

Browse Source
This commit is contained in:
peter 2000-11-11 16:14:03 +00:00
parent efcc15cfee
commit 6ab0380cd9
5 changed files with 706 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
tests/test/testcard.pp Normal file
View File

@ -0,0 +1,102 @@
Program TestCardinal;
{ Tests different features of the cardinal type }
{ We must also test range checking thereafter }
Procedure TestEqualAssign;
var
l : longint;
i : cardinal;
j : cardinal;
Begin
l:=$80000000; { longint }
i:=l; { longint -> cardinal }
j:=i; { cardinal -> cardinal }
l:=j; { cardinal -> longint }
end;
Procedure TestBiggerAssign;
var
b: byte;
c: char;
s: shortint;
i: integer;
w: word;
j: cardinal;
Begin
b:=0;
c:=#$7f;
s:=120;
i:=16384;
w:=32767;
j:=b; { byte -> cardinal }
{ THIS LINE CRASHES THE COMPILER FPC v0.99.5a }
{ j:=c;} { char -> cardinal }
j:=ord(c);{ char -> cardinal }
j:=s; { shortint -> cardinal }
j:=i; { integer -> cardinal }
j:=w; { word -> cardinal }
end;
Procedure TestSmallerAssign;
var
b: byte;
c: char;
s: shortint;
i: integer;
w: word;
j: cardinal;
Begin
j:=$ffffffff;
b:=byte(j);
c:=char(j);
s:=shortint(j);
i:=integer(j);
w:=word(j);
end;
Procedure TestMul;
var
j: cardinal;
k: cardinal;
Begin
j:=1;
k:=$8000000;
j:=j*16384;
j:=j*k
end;
Procedure TestDiv;
var
j: cardinal;
k: cardinal;
Begin
j:=1;
k:=$8000000;
j:=j div 16384;
j:=j div k;
k:=k mod 200;
end;
Procedure TestAdd;
Begin
end;
Procedure TestSub;
Begin
end;
Begin
TestEqualAssign;
TestBiggerAssign;
TestSmallerAssign;
TestMul;
TestDiv;
end.

74
tests/test/testdiv.pp Normal file
View File

@ -0,0 +1,74 @@
Procedure TestDiv;
var
bx,by: byte;
ix,iy: integer;
wx,wy: word;
lx,ly: longint;
Begin
{ byte test }
bx:=10;
by:=5;
bx:=bx div by;
if bx = 2 then
WriteLn('TEST_DIV(1): PASSED.')
else
WriteLn('TEST_DIV(1): FAILED.');
bx:=20;
bx:=bx div 10;
if bx = 2 then
WriteLn('TEST_DIV(2): PASSED.')
else
WriteLn('TEST_DIV(2): FAILED.');
{ integer test }
ix:=-10;
iy:=5;
ix:=ix div iy;
if ix = -2 then
WriteLn('TEST_DIV(3): PASSED.')
else
WriteLn('TEST_DIV(3): FAILED.');
ix:=-20;
ix:=ix div 10;
if ix = -2 then
WriteLn('TEST_DIV(4): PASSED.')
else
WriteLn('TEST_DIV(4): FAILED.');
{ word test }
wx:=64000;
wy:=2;
wx:=wx div wy;
if wx = 32000 then
WriteLn('TEST_DIV(5): PASSED.')
else
WriteLn('TEST_DIV(5): FAILED.');
wx:=20;
wx:=wx div 10;
if wx = 2 then
WriteLn('TEST_DIV(6): PASSED.')
else
WriteLn('TEST_DIV(6): FAILED.');
{ longint test }
lx:=-1000000;
ly:=2;
lx:=lx div ly;
if lx = -500000 then
WriteLn('TEST_DIV(7): PASSED.')
else
WriteLn('TEST_DIV(7): FAILED.');
lx:=-1000000;
lx:=lx div 10;
if lx = -100000 then
WriteLn('TEST_DIV(8): PASSED.')
else
WriteLn('TEST_DIV(8): FAILED.')
end;
Begin
Testdiv;
end.

103
tests/test/testobj.pp Normal file
View File

@ -0,0 +1,103 @@
TYPE
psimpleobject = ^tsimpleobject;
tsimpleobject = object
x: longint;
z: array[0..34] of byte;
Procedure Init(somez: longint);
Procedure Hello;
end;
pbase = ^tbase;
tbase = object
numofentries : longint;
constructor init(i : integer);
destructor done; virtual;
procedure showit; virtual;
end;
pderived = ^tderived;
tderived = object(tbase)
x: longint;
constructor init;
destructor done; virtual;
procedure showit; virtual;
end;
Procedure TsimpleObject.init(somez: longint);
var
i: byte;
Begin
for i:=0 to 34 do
z[i]:=i;
x:=somez;
end;
Procedure TSimpleObject.hello;
var
i: byte;
Begin
WriteLn('hello world');
for i:=0 to 34 do
Write(z[i],' ');
WriteLn;
WriteLN(x);
end;
constructor tbase.init(i: integer);
Begin
numofentries := i;
end;
destructor tbase.done;
Begin
end;
procedure tbase.showit;
Begin
WriteLn('This is the base class');
end;
constructor tderived.init;
Begin
inherited init(5);
x:=10;
end;
procedure tderived.showit;
Begin
WriteLn('This is the derived class');
WriteLn(numofentries);
WriteLn(x);
end;
destructor tderived.done;
Begin
end;
Procedure CreateObject;
var
obj: pbase;
Begin
obj^.showit;
dispose(obj,done);
end;
var
myobj: tsimpleobject;
obj: pbase;
devobj: tderived;
Begin
WriteLn(MemAvail);
obj:=new(pbase,init(10));
obj^.showit;
WriteLn(MemAvail);
dispose(obj,done);
WriteLn(MemAvail);
end.

76
tests/test/testreal.pp Normal file
View File

@ -0,0 +1,76 @@
{$E-}
Procedure TestSub;
var
i : Real;
j : Real;
Begin
i:=99.9;
j:=10.0;
i:=i-j;
Write('RESULT SHOULD BE: 89.9 :');
WriteLn(i);
i:=j-i;
Write('RESULT SHOULD BE: -79.9 :');
WriteLn(i);
j:=j-10.0;
Write('RESULT SHOULD BE: 0.0 :');
WriteLn(j);
end;
Function TestAdd(i : real): Real;
Begin
i:=i+1.5;
if i > 10.0 then
Begin
Write('RESULT SHOULD BE: 10.5 :');
WriteLn(i);
exit;
end;
TestAdd:=TestAdd(i);
end;
Procedure TestDiv;
var
i : Real;
j : Real;
Begin
i:=-99.9;
j:=10.0;
i:=i / j;
Write('RESULT SHOULD BE: -9.9 :');
WriteLn(i);
i:=j / i;
Write('RESULT SHOULD BE: -1.01 :');
WriteLn(i);
j:=i / 10.0;
Write('RESULT SHOULD BE: -0.1001 :');
WriteLn(j);
end;
Procedure TestComplex;
var
i : real;
Begin
Write('RESULT SHOULD BE 2.09 :');
i := 4.4;
WriteLn(Sqrt(i));
Write('RESULT SHOULD BE PI :');
WriteLn(Pi);
Write('RESULT SHOULD BE 4.0 :');
WriteLn(Round(3.6));
end;
Begin
WriteLn('------------ SUB ---------------');
TestSub;
WriteLn('------------ ADD ---------------');
TestAdd(0);
WriteLn('------------ DIV ---------------');
TestDiv;
WriteLn('------------ COMPLEX ---------------');
TestComplex;
end.

351
tests/test/testset2.pp Normal file
View File

@ -0,0 +1,351 @@
(*********************************************************************)
(* Copyright (C) 1998, Carl Eric Codere *)
(*********************************************************************)
(* FPC (Free Pascal compiler) testsuite: SETS *)
(* Tests the following: in, +, -, *, assignments. *)
(* for small sets amd large sets, both with constants *)
(* and variables. *)
(*********************************************************************)
type
myenum = (dA,dB,dC,dd,dedf,dg,dh,di,dj,dk,dl,dm,dn);
tasmop = (A_ABCD,
A_ADD,A_ADDA,A_ADDI,A_ADDQ,A_ADDX,A_AND,A_ANDI,
A_ASL,A_ASR,A_BCC,A_BCS,A_BEQ,A_BGE,A_BGT,A_BHI,
A_BLE,A_BLS,A_BLT,A_BMI,A_BNE,A_BPL,A_BVC,A_BVS,
A_BCHG,A_BCLR,A_BRA,A_BSET,A_BSR,A_BTST,A_CHK,
A_CLR,A_CMP,A_CMPA,A_CMPI,A_CMPM,A_DBCC,A_DBCS,A_DBEQ,A_DBGE,
A_DBGT,A_DBHI,A_DBLE,A_DBLS,A_DBLT,A_DBMI,A_DBNE,A_DBRA,
A_DBPL,A_DBT,A_DBVC,A_DBVS,A_DBF,A_DIVS,A_DIVU,
A_EOR,A_EORI,A_EXG,A_ILLEGAL,A_EXT,A_JMP,A_JSR,
A_LEA,A_LINK,A_LSL,A_LSR,A_MOVE,A_MOVEA,A_MOVEI,A_MOVEQ,
A_MOVEM,A_MOVEP,A_MULS,A_MULU,A_NBCD,A_NEG,A_NEGX,
A_NOP,A_NOT,A_OR,A_ORI,A_PEA,A_ROL,A_ROR,A_ROXL,
A_ROXR,A_RTR,A_RTS,A_SBCD,A_SCC,A_SCS,A_SEQ,A_SGE,
A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,A_SNE,
A_SPL,A_ST,A_SVC,A_SVS,A_SF,A_SUB,A_SUBA,A_SUBI,A_SUBQ,
A_SUBX,A_SWAP,A_TAS,A_TRAP,A_TRAPV,A_TST,A_UNLK,
A_RTE,A_RESET,A_STOP,
{ MC68010 instructions }
A_BKPT,A_MOVEC,A_MOVES,A_RTD,
{ MC68020 instructions }
A_BFCHG,A_BFCLR,A_BFEXTS,A_BFEXTU,A_BFFFO,
A_BFINS,A_BFSET,A_BFTST,A_CALLM,A_CAS,A_CAS2,
A_CHK2,A_CMP2,A_DIVSL,A_DIVUL,A_EXTB,A_PACK,A_RTM,
A_TRAPCC,A_TRACS,A_TRAPEQ,A_TRAPF,A_TRAPGE,A_TRAPGT,
A_TRAPHI,A_TRAPLE,A_TRAPLS,A_TRAPLT,A_TRAPMI,A_TRAPNE,
A_TRAPPL,A_TRAPT,A_TRAPVC,A_TRAPVS,A_UNPK,
{ FPU Processor instructions - directly supported only. }
{ IEEE aware and misc. condition codes not supported }
A_FABS,A_FADD,
A_FBEQ,A_FBNE,A_FBNGT,A_FBGT,A_FBGE,A_FBNGE,
A_FBLT,A_FBNLT,A_FBLE,A_FBGL,A_FBNGL,A_FBGLE,A_FBNGLE,
A_FDBEQ,A_FDBNE,A_FDBGT,A_FDBNGT,A_FDBGE,A_FDBNGE,
A_FDBLT,A_FDBNLT,A_FDBLE,A_FDBGL,A_FDBNGL,A_FDBGLE,A_FBDNGLE,
A_FSEQ,A_FSNE,A_FSGT,A_FSNGT,A_FSGE,A_FSNGE,
A_FSLT,A_FSNLT,A_FSLE,A_FSGL,A_FSNGL,A_FSGLE,A_FSNGLE,
A_FCMP,A_FDIV,A_FMOVE,A_FMOVEM,
A_FMUL,A_FNEG,A_FNOP,A_FSQRT,A_FSUB,A_FSGLDIV,
A_FSFLMUL,A_FTST,
A_FTRAPEQ,A_FTRAPNE,A_FTRAPGT,A_FTRAPNGT,A_FTRAPGE,A_FTRAPNGE,
A_FTRAPLT,A_FTRAPNLT,A_FTRAPLE,A_FTRAPGL,A_FTRAPNGL,A_FTRAPGLE,A_FTRAPNGLE,
{ Protected instructions }
A_CPRESTORE,A_CPSAVE,
{ FPU Unit protected instructions }
{ and 68030/68851 common MMU instructions }
{ (this may include 68040 MMU instructions) }
A_FRESTORE,A_FSAVE,A_PFLUSH,A_PFLUSHA,A_PLOAD,A_PMOVE,A_PTEST,
{ Useful for assembly langage output }
A_LABEL,A_NONE);
Function X(y:myenum): myenum;
Begin
x:=y;
end;
Procedure SecondInSets;
{ SET_IN_BYTE TESTS }
var
op : tasmop;
oplist: set of tasmop;
Begin
Write('TESTING SET_IN_BYTE:');
oplist:=[];
op:=A_JSR;
if op in oplist then
WriteLn(' FAILED.');
op:=A_MOVE;
oplist:=oplist+[A_MOVE];
if op in oplist then
WriteLn(' PASSED.');
end;
Procedure SetSetByte;
{ SET_SET_BYTE }
var
op : tasmop;
oplist: set of tasmop;
Begin
Write('TESTING SET_SET_BYTE(1):');
op:=A_LABEL;
oplist:=[];
oplist:=oplist+[op];
if op in oplist then
Begin
WriteLn(' PASSED.');
end
else
Begin
WriteLn(' FAILED.');
end;
end;
Procedure SetAddSets;
{ SET_ADD_SETS }
var
op2list :set of tasmop;
oplist: set of tasmop;
Begin
op2list:=[];
oplist:=[];
oplist:=[A_MOVE]+[A_JSR];
op2list:=[A_LABEL];
oplist:=op2list+oplist;
if A_MOVE in oplist then
if A_LABEL in oplist then
if A_JSR in oplist then
WriteLn('TESTING SET_ADD_SETS: PASSED.')
else
WriteLn('TESTING SET_ADD_SETS: FAILED.')
else
WriteLn('TESTING SET_ADD_SETS: FAILED.')
else
WriteLn('TESTING SET_ADD_SETS: FAILED.')
end;
Procedure SetSubsets;
{ SET_SUB_SETS }
var
op2list :set of tasmop;
oplist: set of tasmop;
Begin
op2list:=[];
oplist:=[];
oplist:=[A_MOVE]+[A_JSR];
op2list:=[A_MOVE]+[A_JSR];
oplist:=op2list-oplist;
if (A_MOVE in oplist) or (A_LABEL in oplist) or (A_JSR in oplist) then
WriteLn('TESTING SET_SUB_SETS: FAILED.')
else
WriteLn('TESTING SET_SUB_SETS: PASSED.')
end;
Procedure SetCompSets;
{ SET_COMP_SETS }
var
op2list :set of tasmop;
oplist: set of tasmop;
Begin
op2list:=[];
oplist:=[];
oplist:=[A_MOVE]+[A_JSR];
op2list:=[A_MOVE]+[A_JSR];
if oplist=op2list then
WriteLn('TESTING SET_COMP_SETS(1): PASSED.')
else
WriteLn('TESTING SET_COMP_SETS(1): FAILED.');
oplist:=[A_MOVE];
if oplist=op2list then
WriteLn('TESTING SET_COMP_SETS(2): FAILED.')
else
WriteLn('TESTING SET_COMP_SETS(2): PASSED.');
end;
Procedure SetMulSets;
{ SET_COMP_SETS }
var
op2list :set of tasmop;
oplist: set of tasmop;
Begin
op2list:=[];
oplist:=[];
oplist:=[A_MOVE]+[A_JSR];
op2list:=[A_MOVE];
oplist:=oplist*op2list;
if A_JSR in oplist then
WriteLn('TESTING SET_MUL_SETS(1): FAILED.')
else
WriteLn('TESTING SET_MUL_SETS(1): PASSED.');
if A_MOVE in oplist then
WriteLn('TESTING SET_MUL_SETS(2): PASSED.')
else
WriteLn('TESTING SET_MUL_SETS(2): FAILED.')
end;
{------------------------------ TESTS FOR SMALL VALUES ---------------------}
Procedure SmallInSets;
{ SET_IN_BYTE TESTS }
var
op : myenum;
oplist: set of myenum;
Begin
Write('TESTING IN_BYTE:');
oplist:=[];
op:=Dn;
if op in oplist then
WriteLn(' FAILED.');
op:=dm;
oplist:=oplist+[Dm];
if op in oplist then
WriteLn(' PASSED.');
end;
Procedure SmallSetByte;
{ SET_SET_BYTE }
var
op : myenum;
oplist: set of myenum;
Begin
Write('TESTING SET_BYTE(1):');
op:=DA;
oplist:=[];
oplist:=oplist+[op];
if op in oplist then
Begin
WriteLn(' PASSED.');
end
else
Begin
WriteLn(' FAILED.');
end;
end;
Procedure SmallAddSets;
{ SET_ADD_SETS }
var
op2list :set of myenum;
oplist: set of myenum;
Begin
op2list:=[];
oplist:=[];
oplist:=[DA]+[DC];
op2list:=[DB];
oplist:=op2list+oplist;
if DA in oplist then
if DC in oplist then
if DB in oplist then
WriteLn('TESTING SET_ADD_SETS: PASSED.')
else
WriteLn('TESTING ADD_SETS: FAILED.')
else
WriteLn('TESTING ADD_SETS: FAILED.')
else
WriteLn('TESTING ADD_SETS: FAILED.')
end;
Procedure SmallSubsets;
{ SET_SUB_SETS }
var
op2list :set of myenum;
oplist: set of myenum;
Begin
op2list:=[];
oplist:=[];
oplist:=[DA]+[DC];
op2list:=[DA]+[DC];
oplist:=op2list-oplist;
if (DA in oplist) or (DB in oplist) or (DC in oplist) then
WriteLn('TESTING SUB_SETS: FAILED.')
else
WriteLn('TESTING SUB_SETS: PASSED.')
end;
Procedure SmallCompSets;
{ SET_COMP_SETS }
var
op2list :set of myenum;
oplist: set of myenum;
Begin
op2list:=[];
oplist:=[];
oplist:=[DA]+[DC];
op2list:=[DA]+[DC];
if oplist=op2list then
WriteLn('TESTING COMP_SETS(1): PASSED.')
else
WriteLn('TESTING COMP_SETS(1): FAILED.');
oplist:=[DA];
if oplist=op2list then
WriteLn('TESTING COMP_SETS(2): FAILED.')
else
WriteLn('TESTING COMP_SETS(2): PASSED.');
end;
Procedure SmallMulSets;
{ SET_COMP_SETS }
var
op2list :set of myenum;
oplist: set of myenum;
Begin
op2list:=[];
oplist:=[];
oplist:=[DA]+[DC];
op2list:=[DA];
oplist:=oplist*op2list;
if DC in oplist then
WriteLn('TESTING MUL_SETS(1): FAILED.')
else
WriteLn('TESTING MUL_SETS(1): PASSED.');
if DA in oplist then
WriteLn('TESTING MUL_SETS(2): PASSED.')
else
WriteLn('TESTING MUL_SETS(2): FAILED.')
end;
const
b: myenum = (dA);
var
enum: set of myenum;
oplist: set of tasmop;
l : word;
Begin
{ small sets }
enum:=[];
{ add }
enum:=enum+[da];
{ subtract }
enum:=enum-[da];
if DA in enum then
WriteLn('Found A_LABEL');
{ very large sets }
{ copy loop test }
WRITELN('LARGE SETS:');
oplist := [A_LABEL];
{ secondin test }
if A_LABEL in oplist then
WriteLn('TESTING SIMPLE SECOND_IN: PASSED.');
{ }
oplist:=[];
if A_LABEL in oplist then
WriteLn('SECOND IN FAILED.');
SecondinSets;
SetSetByte;
SetAddSets;
SetSubSets;
SetCompSets;
SetMulSets;
WRITELN('SMALL SETS:');
SmallInSets;
SmallAddSets;
SmallSubSets;
SmallCompSets;
SmallMulSets;
l:=word(A_CPRESTORE);
if l = word(A_CPRESTORE) then
Begin
end;
end.