diff --git a/tests/webtbs/tw1044.pp b/tests/webtbs/tw1044.pp new file mode 100644 index 0000000000..1e2bc68344 --- /dev/null +++ b/tests/webtbs/tw1044.pp @@ -0,0 +1,21 @@ +{ %NORUN } +{ DONT RUN THIS CODE, its creates an infinite recursion } +{ Code unchanged as this is a test for a compile time GPF. PM } +{ Source provided for Free Pascal Bug Report 1044 } +{ Submitted by "Geoffrey A Swift" on 2000-07-16 } +{ e-mail: blimey@toke.com } +{$mode objfpc} +type + subrange = 1..6; + subset = set of subrange; +function solve(numbers : subset) : boolean; +var + i: subrange; +begin + if numbers <> [] then + for i := low(subrange) to high(subrange) do + result := solve(numbers - [i]) +end; +begin + solve([1,2,3,4,5,6]) +end. \ No newline at end of file diff --git a/tests/webtbs/tw1050.pp b/tests/webtbs/tw1050.pp new file mode 100644 index 0000000000..d0d34edd90 --- /dev/null +++ b/tests/webtbs/tw1050.pp @@ -0,0 +1,50 @@ +{ %GRAPH } +{ Source provided for Free Pascal Bug Report 1050 } +{ Submitted by "Jonathan Ball" on 2000-07-17 } +{ e-mail: j.ball@rgu.ac.uk } +PROGRAM test; +USES Crt, Graph; +VAR + bpoint : pointer; + bsize, actual : longint; + f : file; + s : string; + i : BYTE; + +{------------------PROCEDURES-------------------} +PROCEDURE GraphInit; +VAR gd,gm : INTEGER; +BEGIN + gd:=VGA; {gd:=DETECT;} gm:=VGAHi; + InitGraph (gd,gm, '.\bgi'); + gd:=graphresult; + IF gd<>grok THEN + BEGIN + WRITELN('Error initialising graphic card!'); + WRITELN(grapherrormsg(gd));HALT; + END +END; + +{---------------MAIN PROGRAM BODY----------------} +BEGIN + GraphInit; + i := 0; + s := 'test'; {set file name} + REPEAT + i := i + 1; {increment size} + BSize := ImageSize(0,0,i,i); {buffer size} + GETMEM(bpoint,bsize); {reserve buffer} + GetImage(0,0,i,i,bpoint^); {store in buffer} + writeln(i,' ',bsize); + ASSIGN(f,s); + REWRITE(f,1); + BLOCKWRITE(f,bpoint^,bsize,actual); + CLOSE(f); + FREEMEM(bpoint,bsize); {release memory} + UNTIL (i=255){FALSE}; {until error} + CloseGraph; +END. + +{OUTPUT: program runs OK until i=31 and } +{bsize=2060 bytes. When i increments to 32} +{(bsize=2190), runtime error is generated } \ No newline at end of file diff --git a/tests/webtbs/tw1229.pp b/tests/webtbs/tw1229.pp new file mode 100644 index 0000000000..bb0da412ea --- /dev/null +++ b/tests/webtbs/tw1229.pp @@ -0,0 +1,24 @@ +{ %CPU=i386 } +{ Source provided for Free Pascal Bug Report 1229 } +{ Submitted by "Rich Pasco" on 2000-11-10 } +{ e-mail: pasco@acm.org } + +{$asmmode intel } + +procedure SomePostScript; assembler; + asm + db '/pop2 { pop pop } def',0; + end; +var + st : string; +begin + WriteLn(pchar(@SomePostScript)); + st:=strpas(pchar(@SomePostScript)); + if st<>'/pop2 { pop pop } def' then + begin + Writeln('Error in assembler parsing'); + if st='/pop2 def' then + Writeln('Assembler parser removes comments'); + Halt(1); + end; +end. diff --git a/tests/webtbs/tw1430.pp b/tests/webtbs/tw1430.pp new file mode 100644 index 0000000000..34087bc870 --- /dev/null +++ b/tests/webtbs/tw1430.pp @@ -0,0 +1,20 @@ +{ Source provided for Free Pascal Bug Report 1430 } +{ Submitted by "Keith R. Bolson" on 2001-03-07 } +{ e-mail: krbolson@visi.com } +PROGRAM fpc1; + + +PROCEDURE DoType( b :BOOLEAN; t,f: STRING); +BEGIN + IF b THEN writeln(t) ELSE writeln(f); + if b then + halt(1); +END; + +VAR + ax, ay: Char; + +BEGIN + ax := 'X'; ay := 'Y'; + DoType( ( ([ax, ay] * ['A','C','D']) <> []), 'yes', 'no'); +END. diff --git a/tests/webtbs/tw1485.pp b/tests/webtbs/tw1485.pp new file mode 100644 index 0000000000..007d8053f0 --- /dev/null +++ b/tests/webtbs/tw1485.pp @@ -0,0 +1,24 @@ +{ Source provided for Free Pascal Bug Report 1485 } +{ Submitted by "Petr Titera" on 2001-05-01 } +{ e-mail: owl@volny.cz } + +{$mode objfpc} + +Type + TLang = (French,Czech,English); + +Function Test : TLang; +begin + Test:=French; + try + Exit(Czech); + except + end; +end; + +Begin + Writeln(Integer(Test)); + if Test<>Czech then + RunError(1); + Writeln(Integer(Czech)); +End. \ No newline at end of file diff --git a/tests/webtbs/tw1592.pp b/tests/webtbs/tw1592.pp new file mode 100644 index 0000000000..beca0783d4 --- /dev/null +++ b/tests/webtbs/tw1592.pp @@ -0,0 +1,38 @@ +{ Source provided for Free Pascal Bug Report 1592 } +{ Submitted by "Guenther Palfinger" on 2001-08-23 } +{ e-mail: guenther.palfinger@gmx.net } +Program ShowBug; (* 2001-08-23 *) + +var L,R,A,B,Z1,tmp : real; + +function arccos(x: real): real; +var y : real; +begin + (* gdb gives the following message for next line: + * "Program received signal SIGFPE, Arithmetic exception." *) + writeln(x); + if abs(x) > 1.0 then writeln(' error arccos(x), x = ',x:7:3); + if abs(x) > 0.0 then y := arctan(sqrt(1.0-x*x)/abs(x)) + else y := pi/2.0; + if x < 0.0 then y := pi - y; + arccos := y; +end; + +function arcsin(x: real): real; +begin + arcsin := pi/2.0 - arccos(x); +end; + +begin + L := 5.2631578947368425; + R := 3.6315789473684212; + A := 39.88919667590028; + B := 15.512465373961222; + (* Behaves OK *) + tmp := 1/(pi*R)*(ArcCos(B/A) - 1/(2*L)*(sqrt((A+2)*(A+2)-2*R*R)*ArcCos(B/(R*A)) + B*ArcSin(1/R) )); + writeln ('tmp = ', tmp); + (* OK *) + writeln('1/R-tmp = ', 1/R-tmp); + (* Next line causes FPE at run time, althogh it is the same as previous line *) + Z1 := 1/R- 1/(pi*R)*(ArcCos(B/A) - 1/(2*L)*(sqrt((A+2)*(A+2)-2*R*R)*ArcCos(B/(R*A)) + B*ArcSin(1/R) )); +end. \ No newline at end of file