summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/test/tgenfunc24.pp25
-rw-r--r--tests/test/tgenfunc25.pp24
-rw-r--r--tests/test/tgenfunc26.pp24
-rw-r--r--tests/test/tgenfunc27.pp24
-rw-r--r--tests/test/units/math/trndcurr.pp156
-rw-r--r--tests/webtbf/tw38289a.pp8
-rw-r--r--tests/webtbf/tw38289b.pp8
-rw-r--r--tests/webtbs/tw38267b.pp31
-rw-r--r--tests/webtbs/tw38295.pp19
-rw-r--r--tests/webtbs/tw38299.pp15
10 files changed, 329 insertions, 5 deletions
diff --git a/tests/test/tgenfunc24.pp b/tests/test/tgenfunc24.pp
new file mode 100644
index 0000000000..ca592be8d5
--- /dev/null
+++ b/tests/test/tgenfunc24.pp
@@ -0,0 +1,25 @@
+{ %FAIL }
+
+program tgenfunc24;
+
+{$mode delphi}
+
+type
+ TTest = class
+ public type
+ Test = class
+ end;
+
+ public
+ procedure Test<T>;
+ end;
+
+procedure TTest.Test<T>;
+begin
+
+end;
+
+begin
+
+end.
+
diff --git a/tests/test/tgenfunc25.pp b/tests/test/tgenfunc25.pp
new file mode 100644
index 0000000000..3728c37807
--- /dev/null
+++ b/tests/test/tgenfunc25.pp
@@ -0,0 +1,24 @@
+{ %FAIL }
+
+program tgenfunc25;
+
+{$mode delphi}
+
+type
+ TTest = class
+ public
+ procedure Test<T>;
+ public type
+ Test = class
+ end;
+ end;
+
+procedure TTest.Test<T>;
+begin
+
+end;
+
+begin
+
+end.
+
diff --git a/tests/test/tgenfunc26.pp b/tests/test/tgenfunc26.pp
new file mode 100644
index 0000000000..f0f34b9b13
--- /dev/null
+++ b/tests/test/tgenfunc26.pp
@@ -0,0 +1,24 @@
+{ %FAIL }
+
+unit tgenfunc26;
+
+{$mode objfpc}{$H+}
+
+interface
+
+generic procedure Test<T>;
+
+type
+ Test = record
+
+ end;
+
+implementation
+
+generic procedure Test<T>;
+begin
+
+end;
+
+end.
+
diff --git a/tests/test/tgenfunc27.pp b/tests/test/tgenfunc27.pp
new file mode 100644
index 0000000000..ea18a34fea
--- /dev/null
+++ b/tests/test/tgenfunc27.pp
@@ -0,0 +1,24 @@
+{ %FAIL }
+
+unit tgenfunc27;
+
+{$mode objfpc}{$H+}
+
+interface
+
+type
+ Test = record
+
+ end;
+
+generic procedure Test<T>;
+
+implementation
+
+generic procedure Test<T>;
+begin
+
+end;
+
+end.
+
diff --git a/tests/test/units/math/trndcurr.pp b/tests/test/units/math/trndcurr.pp
index 1c198789eb..a98728160c 100644
--- a/tests/test/units/math/trndcurr.pp
+++ b/tests/test/units/math/trndcurr.pp
@@ -1,13 +1,34 @@
uses
Math;
+
+const
+ failure_count : longint = 0;
+ first_error : longint = 0;
+
{$ifndef SKIP_CURRENCY_TEST}
procedure testround(const c, expected: currency; error: longint);
begin
if round(c)<>expected then
begin
writeln('round(',c,') = ',round(c),' instead of ', expected);
- halt(error);
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=error;
+ end;
+end;
+{$endif}
+
+
+{$ifndef SKIP_SINGLE_TEST}
+procedure testroundsingle(const c, expected: single; error: longint);
+begin
+ if round(c)<>expected then
+ begin
+ writeln('round(',c,') = ',round(c),' instead of ', expected);
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=error;
end;
end;
@@ -16,6 +37,13 @@ end;
begin
{$ifndef SKIP_CURRENCY_TEST}
+ if GetRoundMode <> rmNearest then
+ begin
+ writeln('Starting rounding mode is not rmNearest');
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=200;
+ end;
writeln('Rounding mode: rmNearest (even)');
testround(0.5,0.0,1);
testround(1.5,2.0,2);
@@ -31,7 +59,15 @@ begin
testround(-1.4,-1.0,154);
writeln('Rounding mode: rmUp');
- SetRoundMode(rmUp);
+ if SetRoundMode(rmUp)<>rmNearest then
+ writeln('Warning: previous mode was not rmNearest');
+ if GetRoundMode <> rmUp then
+ begin
+ writeln('Failed to set rounding mode to rmUp');
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=201;
+ end;
testround(0.5,1.0,5);
testround(1.5,2.0,6);
testround(-0.5,0.0,7);
@@ -46,7 +82,15 @@ begin
testround(-1.4,-1.0,158);
writeln('Rounding mode: rmDown');
- SetRoundMode(rmDown);
+ if SetRoundMode(rmDown)<>rmUp then
+ writeln('Warning: previous mode was not rmUp');
+ if GetRoundMode <> rmDown then
+ begin
+ writeln('Failed to set rounding mode to rmDown');
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=202;
+ end;
testround(0.5,0.0,9);
testround(1.5,1.0,10);
testround(-0.5,-1.0,11);
@@ -61,7 +105,15 @@ begin
testround(-1.4,-2.0,162);
writeln('Rounding mode: rmTruncate');
- SetRoundMode(rmTruncate);
+ if SetRoundMode(rmTruncate)<>rmDown then
+ writeln('Warning: previous mode was not rmDown');
+ if GetRoundMode <> rmTruncate then
+ begin
+ writeln('Failed to set rounding mode to rmTruncate');
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=203;
+ end;
testround(0.5,0.0,13);
testround(1.5,1.0,14);
testround(-0.5,0.0,15);
@@ -75,4 +127,100 @@ begin
testround(-0.4,0.0,165);
testround(-1.4,-1.0,166);
{$endif}
+{$ifndef SKIP_SINGLE_TEST}
+ SetRoundMode(rmNearest);
+ if GetRoundMode <> rmNearest then
+ begin
+ writeln('Starting rounding mode is not rmNearest');
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=200;
+ end;
+ writeln('Rounding mode: rmNearest (even)');
+ testroundsingle(0.5,0.0,1);
+ testroundsingle(1.5,2.0,2);
+ testroundsingle(-0.5,0.0,3);
+ testroundsingle(-1.5,-2.0,4);
+ testroundsingle(0.6,1.0,101);
+ testroundsingle(1.6,2.0,102);
+ testroundsingle(-0.6,-1.0,103);
+ testroundsingle(-1.6,-2.0,104);
+ testroundsingle(0.4,0.0,151);
+ testroundsingle(1.4,1.0,152);
+ testroundsingle(-0.4,-0.0,153);
+ testroundsingle(-1.4,-1.0,154);
+
+ writeln('Rounding mode: rmUp');
+ if SetRoundMode(rmUp)<>rmNearest then
+ writeln('Warning: previous mode was not rmNearest');
+ if GetRoundMode <> rmUp then
+ begin
+ writeln('Failed to set rounding mode to rmUp');
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=201;
+ end;
+ testroundsingle(0.5,1.0,5);
+ testroundsingle(1.5,2.0,6);
+ testroundsingle(-0.5,0.0,7);
+ testroundsingle(-1.5,-1.0,8);
+ testroundsingle(0.6,1.0,105);
+ testroundsingle(1.6,2.0,106);
+ testroundsingle(-0.6,0.0,107);
+ testroundsingle(-1.6,-1.0,108);
+ testroundsingle(0.4,1.0,155);
+ testroundsingle(1.4,2.0,156);
+ testroundsingle(-0.4,0.0,157);
+ testroundsingle(-1.4,-1.0,158);
+
+ writeln('Rounding mode: rmDown');
+ if SetRoundMode(rmDown)<>rmUp then
+ writeln('Warning: previous mode was not rmUp');
+ if GetRoundMode <> rmDown then
+ begin
+ writeln('Failed to set rounding mode to rmDown');
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=202;
+ end;
+ testroundsingle(0.5,0.0,9);
+ testroundsingle(1.5,1.0,10);
+ testroundsingle(-0.5,-1.0,11);
+ testroundsingle(-1.5,-2.0,12);
+ testroundsingle(0.6,0.0,109);
+ testroundsingle(1.6,1.0,110);
+ testroundsingle(-0.6,-1.0,111);
+ testroundsingle(-1.6,-2.0,112);
+ testroundsingle(0.4,0.0,159);
+ testroundsingle(1.4,1.0,160);
+ testroundsingle(-0.4,-1.0,161);
+ testroundsingle(-1.4,-2.0,162);
+
+ writeln('Rounding mode: rmTruncate');
+ if SetRoundMode(rmTruncate)<>rmDown then
+ writeln('Warning: previous mode was not rmDown');
+ if GetRoundMode <> rmTruncate then
+ begin
+ writeln('Failed to set rounding mode to rmTruncate');
+ inc(failure_count);
+ if first_error=0 then
+ first_error:=203;
+ end;
+ testroundsingle(0.5,0.0,13);
+ testroundsingle(1.5,1.0,14);
+ testroundsingle(-0.5,0.0,15);
+ testroundsingle(-1.5,-1.0,16);
+ testroundsingle(0.6,0.0,113);
+ testroundsingle(1.6,1.0,114);
+ testroundsingle(-0.6,0.0,115);
+ testroundsingle(-1.6,-1.0,116);
+ testroundsingle(0.4,0.0,163);
+ testroundsingle(1.4,1.0,164);
+ testroundsingle(-0.4,0.0,165);
+ testroundsingle(-1.4,-1.0,166);
+{$endif}
+ if failure_count=0 then
+ writeln('SetRoundMode test finished OK')
+ else
+ halt(first_error);
end.
diff --git a/tests/webtbf/tw38289a.pp b/tests/webtbf/tw38289a.pp
new file mode 100644
index 0000000000..9e89a8a9df
--- /dev/null
+++ b/tests/webtbf/tw38289a.pp
@@ -0,0 +1,8 @@
+{ %FAIL }
+
+library tw38289a;
+procedure Test; begin end;
+exports
+ Test index 3 'abc';
+ //------------^^^
+end.
diff --git a/tests/webtbf/tw38289b.pp b/tests/webtbf/tw38289b.pp
new file mode 100644
index 0000000000..5229c86a3a
--- /dev/null
+++ b/tests/webtbf/tw38289b.pp
@@ -0,0 +1,8 @@
+{ %FAIL }
+
+library tw38289b;
+procedure Test; begin end;
+exports
+ Test index 'abc' 3;
+ //------------^^^
+end.
diff --git a/tests/webtbs/tw38267b.pp b/tests/webtbs/tw38267b.pp
index 4dd0449d81..df7ee09010 100644
--- a/tests/webtbs/tw38267b.pp
+++ b/tests/webtbs/tw38267b.pp
@@ -1,6 +1,6 @@
{ %opt=-O3 -Sg }
{$mode objfpc} {$longstrings+}
-label start1, end1, start2, end2, start3, end3;
+label start1, end1, start2, end2, start3, end3, start4, end4;
var
s: string;
@@ -88,5 +88,34 @@ end3:
if PtrUint(CodePointer(@end3) - CodePointer(@start3))>300 then
halt(3);
writeln;
+
+ writeln('31 literals concatenated with 1 dynamic string, they could fold but didn''t at all:');
+start4:
+ s := 'Once like a Great House' + (LineEnding +
+ ('founded on sand,' + (LineEnding +
+ ('Stood our Temple' + (LineEnding +
+ ('whose pillars on troubles were based.' + (LineEnding +
+ ('Now mischievous spirits, bound,' + (LineEnding +
+ ('in dim corners stand,' + (LineEnding +
+ ('Rotted columns, but' + (LineEnding +
+ ('with iron-bound bands embraced' + (LineEnding +
+ ('Cracked, crumbling marble,' + (LineEnding +
+ ('tempered on every hand,' + (LineEnding +
+ ('By strong steel' + (LineEnding +
+ ('forged in fire and faith.' + (LineEnding +
+ ('Shackled, these wayward servants' + (LineEnding +
+ ('serve the land,' + (LineEnding +
+ ('The Temple secured' + (LineEnding +
+ ('by the Builder’s grace.' +
+ Copy('', 1, 0)))))))))))))))))))))))))))))));
+end4:
+ writeln(Copy(s, 1, 0), PtrUint(CodePointer(@end4) - CodePointer(@start4)), ' b of code');
+ { more than 100 bytes of code might point out that the constants are not folded,
+ example x86_64-linux: not folded: 1384 bytes; folded: 108 bytes
+ }
+ if PtrUint(CodePointer(@end4) - CodePointer(@start4))>300 then
+ halt(4);
+
+
writeln('ok');
end.
diff --git a/tests/webtbs/tw38295.pp b/tests/webtbs/tw38295.pp
new file mode 100644
index 0000000000..eb3eab25ba
--- /dev/null
+++ b/tests/webtbs/tw38295.pp
@@ -0,0 +1,19 @@
+{ %cpu=i386 }
+{ %opt=-CfAVX -CpCOREAVX2 -OoFASTMATH }
+uses
+ cpu;
+var
+ a, b: uint32; // or (u)int64; int32 works
+ r: single; // or double, or even extended
+begin
+ if FMASupport then
+ begin
+ a := 1;
+ b := 3;
+ r := a + b / 10;
+ writeln(r:0:3);
+ if r>2.0 then
+ halt(1);
+ writeln('ok');
+ end;
+end.
diff --git a/tests/webtbs/tw38299.pp b/tests/webtbs/tw38299.pp
new file mode 100644
index 0000000000..8c52902b48
--- /dev/null
+++ b/tests/webtbs/tw38299.pp
@@ -0,0 +1,15 @@
+{ %opt=-O2 -Fcutf8 }
+program bug;
+const
+ cAnsiLineFeed = AnsiChar(#10);
+ cAnsiCarriageReturn = AnsiChar(#13);
+var
+ test: RawByteString;
+begin
+ test := '123';
+ test := test + UTF8Encode('456') + '789' + cAnsiCarriageReturn + cAnsiLineFeed;
+ writeln(test);
+ if test<>'123456789'#13#10 then
+ halt(1);
+ writeln('ok');
+end.
View Lorry Controller Status