+ several new test files

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: [email protected] }
+{$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.

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: [email protected] }
+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 }

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: [email protected] }
+
+{$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.

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: [email protected] }
+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.

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: [email protected] }
+
+{$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.

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: [email protected] }
+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.