* some tests from CEC

tests/test/testcard.pp

@@ -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.
+
+

tests/test/testdiv.pp

@@ -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.

tests/test/testobj.pp

@@ -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.

tests/test/testreal.pp

@@ -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.

tests/test/testset2.pp

@@ -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.