diff --git a/tests/test/units/system/tassert1.pp b/tests/test/units/system/tassert1.pp new file mode 100644 index 0000000000..8b00fca547 --- /dev/null +++ b/tests/test/units/system/tassert1.pp @@ -0,0 +1,69 @@ +{$C+} +program tassert1; + +var + global_boolean : boolean; + +const + RESULT_BOOLEAN = true; + +function get_boolean : boolean; + begin + get_boolean := RESULT_BOOLEAN; + end; + +procedure test_assert_reference_global; + begin + global_boolean:=RESULT_BOOLEAN; + assert(global_boolean); + end; + +procedure test_assert_reference_local; + var + b: boolean; + begin + b:=RESULT_BOOLEAN; + assert(b); + end; + + +procedure test_assert_register; + var + b: boolean; + begin + assert(get_boolean); + end; + +procedure test_assert_flags; + var + b: boolean; + i,j : integer; + begin + i:=0; + j:=-12; + assert(i > j); + end; + +procedure test_assert_constant; + begin + assert(RESULT_BOOLEAN); + end; + + + +begin + Write('Assert test (TRUE)...'); + test_assert_reference_global; + test_assert_reference_local; + test_assert_register; + test_assert_flags; + test_assert_constant; + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:16:36 carl + * several new routines have a testsuit. + +} \ No newline at end of file diff --git a/tests/test/units/system/tassert2.pp b/tests/test/units/system/tassert2.pp new file mode 100644 index 0000000000..12decbf8b3 --- /dev/null +++ b/tests/test/units/system/tassert2.pp @@ -0,0 +1,89 @@ +{$C+} +program tassert2; + +var + global_boolean : boolean; + counter : longint; + +const + RESULT_BOOLEAN = false; + + + +procedure fail; + begin + Writeln('Failure!'); + Halt(1); + end; + +function get_boolean : boolean; + begin + get_boolean := RESULT_BOOLEAN; + end; + +procedure test_assert_reference_global; + begin + global_boolean:=RESULT_BOOLEAN; + assert(global_boolean); + end; + +procedure test_assert_reference_local; + var + b: boolean; + begin + b:=RESULT_BOOLEAN; + assert(b); + end; + + +procedure test_assert_register; + begin + assert(get_boolean); + end; + +procedure test_assert_flags; + var + i,j : integer; + begin + i:=0; + j:=-12; + assert(i < j); + end; + + procedure test_assert_constant; + begin + assert(RESULT_BOOLEAN); + end; + + { Handle the assertion failed ourselves, so we can test everything in + one shot. + } + Procedure MyAssertRoutine(const msg,fname:ShortString;lineno,erroraddr:longint); + begin + Inc(counter); + end; + + + + +begin + counter:=0; + AssertErrorProc := @MyAssertRoutine; + Write('Assert test (FALSE)...'); + test_assert_reference_global; + test_assert_reference_local; + test_assert_register; + test_assert_flags; + test_assert_constant; + if counter <> 5 then + fail + else + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:16:36 carl + * several new routines have a testsuit. + +} \ No newline at end of file diff --git a/tests/test/units/system/tassert3.pp b/tests/test/units/system/tassert3.pp new file mode 100644 index 0000000000..6f135e0dfa --- /dev/null +++ b/tests/test/units/system/tassert3.pp @@ -0,0 +1,88 @@ +{$C-} +program tassert1; + +var + global_boolean : boolean; + counter : longint; + +const + RESULT_BOOLEAN = false; + + +procedure fail; + begin + Writeln('Failure!'); + Halt(1); + end; + +function get_boolean : boolean; + begin + get_boolean := RESULT_BOOLEAN; + end; + +procedure test_assert_reference_global; + begin + global_boolean:=RESULT_BOOLEAN; + assert(global_boolean); + end; + +procedure test_assert_reference_local; + var + b: boolean; + begin + b:=RESULT_BOOLEAN; + assert(b); + end; + + +procedure test_assert_register; + begin + assert(get_boolean); + end; + +procedure test_assert_flags; + var + i,j : integer; + begin + i:=0; + j:=-12; + assert(i < j); + end; + + procedure test_assert_constant; + begin + assert(RESULT_BOOLEAN); + end; + + { Handle the assertion failed ourselves, so we can test everything in + one shot. + } + Procedure MyAssertRoutine(const msg,fname:ShortString;lineno,erroraddr:longint); + begin + Inc(counter); + end; + + + + +begin + counter:=0; + AssertErrorProc := @MyAssertRoutine; + Write('Assert test (FALSE) with assertions off...'); + test_assert_reference_global; + test_assert_reference_local; + test_assert_register; + test_assert_flags; + test_assert_constant; + if counter <> 0 then + fail + else + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:16:36 carl + * several new routines have a testsuit. + +} \ No newline at end of file diff --git a/tests/test/units/system/tassert4.pp b/tests/test/units/system/tassert4.pp new file mode 100644 index 0000000000..f79508d138 --- /dev/null +++ b/tests/test/units/system/tassert4.pp @@ -0,0 +1,90 @@ +{$C+} +program tassert4; + +var + global_boolean : boolean; + counter : longint; + +const + RESULT_BOOLEAN = false; + RESULT_STRING = 'hello world'; + +procedure fail; + begin + Writeln('Failure!'); + Halt(1); + end; + +function get_boolean : boolean; + begin + get_boolean := RESULT_BOOLEAN; + end; + +procedure test_assert_reference_global; + begin + global_boolean:=RESULT_BOOLEAN; + assert(global_boolean,RESULT_STRING); + end; + +procedure test_assert_reference_local; + var + b: boolean; + begin + b:=RESULT_BOOLEAN; + assert(b,RESULT_STRING); + end; + + +procedure test_assert_register; + begin + assert(get_boolean,RESULT_STRING); + end; + +procedure test_assert_flags; + var + i,j : integer; + begin + i:=0; + j:=-12; + assert(i < j,RESULT_STRING); + end; + + procedure test_assert_constant; + begin + assert(RESULT_BOOLEAN,RESULT_STRING); + end; + + { Handle the assertion failed ourselves, so we can test everything in + one shot. + } + Procedure MyAssertRoutine(const msg,fname:ShortString;lineno,erroraddr:longint); + begin + Inc(counter); + if msg <> RESULT_STRING then + fail; + end; + + + + +begin + counter:=0; + AssertErrorProc := @MyAssertRoutine; + Write('Assert test (FALSE) with assertions on...'); + test_assert_reference_global; + test_assert_reference_local; + test_assert_register; + test_assert_flags; + test_assert_constant; + if counter <> 5 then + fail + else + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:16:36 carl + * several new routines have a testsuit. + +} \ No newline at end of file diff --git a/tests/test/units/system/tassert5.pp b/tests/test/units/system/tassert5.pp new file mode 100644 index 0000000000..4d41741217 --- /dev/null +++ b/tests/test/units/system/tassert5.pp @@ -0,0 +1,90 @@ +{$C-} +program tassert5; + +var + global_boolean : boolean; + counter : longint; + +const + RESULT_BOOLEAN = false; + RESULT_STRING = 'hello world'; + +procedure fail; + begin + Writeln('Failure!'); + Halt(1); + end; + +function get_boolean : boolean; + begin + get_boolean := RESULT_BOOLEAN; + end; + +procedure test_assert_reference_global; + begin + global_boolean:=RESULT_BOOLEAN; + assert(global_boolean,RESULT_STRING); + end; + +procedure test_assert_reference_local; + var + b: boolean; + begin + b:=RESULT_BOOLEAN; + assert(b,RESULT_STRING); + end; + + +procedure test_assert_register; + begin + assert(get_boolean,RESULT_STRING); + end; + +procedure test_assert_flags; + var + i,j : integer; + begin + i:=0; + j:=-12; + assert(i < j,RESULT_STRING); + end; + + procedure test_assert_constant; + begin + assert(RESULT_BOOLEAN,RESULT_STRING); + end; + + { Handle the assertion failed ourselves, so we can test everything in + one shot. + } + Procedure MyAssertRoutine(const msg,fname:ShortString;lineno,erroraddr:longint); + begin + Inc(counter); + if msg <> RESULT_STRING then + fail; + end; + + + + +begin + counter:=0; + AssertErrorProc := @MyAssertRoutine; + Write('Assert test (FALSE) with assertions off...'); + test_assert_reference_global; + test_assert_reference_local; + test_assert_register; + test_assert_flags; + test_assert_constant; + if counter <> 0 then + fail + else + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:16:36 carl + * several new routines have a testsuit. + +} \ No newline at end of file diff --git a/tests/test/units/system/tassert6.pp b/tests/test/units/system/tassert6.pp new file mode 100644 index 0000000000..00fe35af28 --- /dev/null +++ b/tests/test/units/system/tassert6.pp @@ -0,0 +1,31 @@ +{ %RESULT=227 } +{$C+} +program tassert6; + +var + global_boolean : boolean; + +const + RESULT_BOOLEAN = false; + + + +procedure test_assert_reference_global; + begin + global_boolean:=RESULT_BOOLEAN; + assert(global_boolean); + end; + + + + +begin + test_assert_reference_global; +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:16:36 carl + * several new routines have a testsuit. + +} \ No newline at end of file diff --git a/tests/test/units/system/tint.pp b/tests/test/units/system/tint.pp new file mode 100644 index 0000000000..ea53fa6943 --- /dev/null +++ b/tests/test/units/system/tint.pp @@ -0,0 +1,72 @@ +{ this tests the int routine } +{ Contrary to TP, int can be used in the constant section, + just like in Delphi } +program tint; + +const + INT_RESULT_ONE = 1234; + INT_VALUE_ONE = 1234.5678; + INT_RESULT_CONST_ONE = Int(INT_VALUE_ONE); + INT_RESULT_TWO = -1234; + INT_VALUE_TWO = -1234.5678; + INT_RESULT_CONST_TWO = Int(INT_VALUE_TWO); + + + procedure fail; + begin + WriteLn('Failed!'); + halt(1); + end; + +var + r: real; + _success : boolean; +Begin + Write('Int() testing...'); + _success := true; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_ONE then + _success:=false; + if Int(INT_VALUE_ONE)<>INT_RESULT_ONE then + _success:=false; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_CONST_ONE then + _success := false; + r:=INT_VALUE_ONE; + r:=Int(r); + if r<>INT_RESULT_ONE then + _success:=false; + r:=Int(INT_VALUE_ONE); + if r<>INT_RESULT_ONE then + _success:=false; + + + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_TWO then + _success:=false; + if Int(INT_VALUE_TWO)<>INT_RESULT_TWO then + _success:=false; + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_CONST_TWO then + _success := false; + r:=INT_VALUE_TWO; + r:=Int(r); + if r<>INT_RESULT_TWO then + _success:=false; + r:=Int(INT_VALUE_TWO); + if r<>INT_RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:15:54 carl + * several new routines have a testsuit. + +} + diff --git a/tests/test/units/system/tpi.pp b/tests/test/units/system/tpi.pp new file mode 100644 index 0000000000..6e4a9ff403 --- /dev/null +++ b/tests/test/units/system/tpi.pp @@ -0,0 +1,38 @@ +{ this tests the pi routine, as an inline } +program tpi; + +const + PI_CONST = 3.1459; + { the following expression also works on constants } + PI_CONST_VALUE = pi; + + procedure fail; + begin + WriteLn('Failed!'); + halt(1); + end; + +var + value : real; + _result : boolean; +Begin + Write('Pi() test...'); + _result := true; + value:=pi; + if trunc(value) <> trunc(PI_CONST) then + _result := false; + If trunc(Pi) <> trunc(PI_CONST) then + _result := false; + If trunc(Pi) <> trunc(PI_CONST_VALUE) then + _result := false; + if not _result then + fail; + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:15:54 carl + * several new routines have a testsuit. + +} \ No newline at end of file diff --git a/tests/test/units/system/tround.pp b/tests/test/units/system/tround.pp new file mode 100644 index 0000000000..3cc81d5010 --- /dev/null +++ b/tests/test/units/system/tround.pp @@ -0,0 +1,71 @@ +{ this tests the round routine } +program ttrunc; + +const + RESULT_ONE = 1235; + VALUE_ONE = 1234.5678; + RESULT_CONST_ONE = round(VALUE_ONE); + RESULT_TWO = -1235; + VALUE_TWO = -1234.5678; + RESULT_CONST_TWO = round(VALUE_TWO); + + + procedure fail; + begin + WriteLn('Failed!'); + halt(1); + end; + +var + r: real; + _success : boolean; + l: longint; +Begin + Write('Round() testing...'); + _success := true; + r:=VALUE_ONE; + if round(r)<>RESULT_ONE then + _success:=false; + if round(VALUE_ONE)<>RESULT_ONE then + _success:=false; + r:=VALUE_ONE; + if round(r)<>RESULT_CONST_ONE then + _success := false; + r:=VALUE_ONE; + l:=round(r); + if l<>RESULT_ONE then + _success:=false; + l:=round(VALUE_ONE); + if l<>RESULT_ONE then + _success:=false; + + + r:=VALUE_TWO; + if round(r)<>RESULT_TWO then + _success:=false; + if round(VALUE_TWO)<>RESULT_TWO then + _success:=false; + r:=VALUE_TWO; + if round(r)<>RESULT_CONST_TWO then + _success := false; + r:=VALUE_TWO; + l:=round(r); + if l<>RESULT_TWO then + _success:=false; + l:=round(VALUE_TWO); + if l<>RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:15:54 carl + * several new routines have a testsuit. + +} + diff --git a/tests/test/units/system/tseg.pp b/tests/test/units/system/tseg.pp new file mode 100644 index 0000000000..4cbf248f5d --- /dev/null +++ b/tests/test/units/system/tseg.pp @@ -0,0 +1,74 @@ +{ Part of System unit testsuit } +{ Carl Eric Codere Copyright (c) 2002 } +program tseg; + +const + cst : integer = 0; +var + variable : integer; + +procedure fail; + begin + WriteLn('Failure!'); + halt(1); + end; + +procedure test_cseg; + begin + Write('Testing CSeg()...'); + if cseg <> 0 then + fail + else + WriteLn('Success!'); + end; + +procedure test_dseg; + begin + Write('Testing DSeg()...'); + if dseg <> 0 then + fail + else + WriteLn('Success!'); + end; + +procedure test_sseg; + begin + Write('Testing SSeg()...'); + if sseg <> 0 then + fail + else + WriteLn('Success!'); + end; + +procedure test_seg; + var + x : longint; + _result : boolean; + begin + _result := true; + Write('Testing Seg()...'); + if seg(x) <> 0 then + _result := false; + if seg(cst) <> 0 then + _result := false; + if seg(variable) <> 0 then + _result := false; + if not _result then + fail + else + WriteLn('Success!'); + end; + +Begin + test_cseg; + test_dseg; + test_seg; + test_sseg; +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:15:54 carl + * several new routines have a testsuit. + +} \ No newline at end of file diff --git a/tests/test/units/system/ttrunc.pp b/tests/test/units/system/ttrunc.pp new file mode 100644 index 0000000000..ac217f01cc --- /dev/null +++ b/tests/test/units/system/ttrunc.pp @@ -0,0 +1,71 @@ +{ this tests the trunc routine } +program ttrunc; + +const + RESULT_ONE = 1234; + VALUE_ONE = 1234.5678; + RESULT_CONST_ONE = trunc(VALUE_ONE); + RESULT_TWO = -1234; + VALUE_TWO = -1234.5678; + RESULT_CONST_TWO = trunc(VALUE_TWO); + + + procedure fail; + begin + WriteLn('Failed!'); + halt(1); + end; + +var + r: real; + _success : boolean; + l: longint; +Begin + Write('Trunc() testing...'); + _success := true; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_ONE then + _success:=false; + if Trunc(VALUE_ONE)<>RESULT_ONE then + _success:=false; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_CONST_ONE then + _success := false; + r:=VALUE_ONE; + l:=Trunc(r); + if l<>RESULT_ONE then + _success:=false; + l:=Trunc(VALUE_ONE); + if l<>RESULT_ONE then + _success:=false; + + + r:=VALUE_TWO; + if Trunc(r)<>RESULT_TWO then + _success:=false; + if Trunc(VALUE_TWO)<>RESULT_TWO then + _success:=false; + r:=VALUE_TWO; + if Trunc(r)<>RESULT_CONST_TWO then + _success := false; + r:=VALUE_TWO; + l:=Trunc(r); + if l<>RESULT_TWO then + _success:=false; + l:=Trunc(VALUE_TWO); + if l<>RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end. + +{ + $Log$ + Revision 1.1 2002-09-16 19:15:54 carl + * several new routines have a testsuit. + +} +