+ many tbs*.pp files

tests/tbs0020.pp

@@ -0,0 +1,28 @@
+{ this program need GPM !! }
+
+uses
+  Gpm;
+
+var
+  Conn: TGPMConnect;
+  Quit: Boolean;
+  Event: TGPMEvent;
+
+begin
+
+  FillChar(Conn, SizeOf(Conn), 0);
+  Conn.EventMask := GPM_MOVE+GPM_DRAG+GPM_DOWN+GPM_UP+GPM_SINGLE+GPM_DOUBLE;
+  Conn.DefaultMask := 0;
+  GPM_Open(Conn, 0);
+  WriteLn('I have opened the mouse... trying to do something tricky...');
+  Quit := False;
+  while not Quit do begin
+    GPM_GetEvent(Event);
+    WriteLn('GetEvent returned... Event.EventType=', Event.EventType);
+    if Event.EventType and GPM_BARE_EVENTS = GPM_DOWN then begin
+      WriteLn('You have pressed a mouse button...');
+      Quit := True;
+    end;
+  end;
+  GPM_Close;
+end.

tests/tbs0021.pp

@@ -0,0 +1,39 @@
+{ tests constant set evalution }
+
+var
+   a : set of byte;
+
+const
+   b : set of byte = [0..255]+[9];
+
+type
+   tcommandset = set of byte;
+
+const
+cmZoom = 10;
+cmClose = 5;
+cmResize = 8;
+cmNext = 12;
+cmPrev = 15;
+
+CONST
+   CurCommandSet : TCommandSet = ([0..255] -
+        [cmZoom, cmClose, cmResize, cmNext, cmPrev]);
+   commands : tcommandset = [];
+
+var
+   CommandSetChanged : boolean;
+
+PROCEDURE DisableCommands (Commands: TCommandSet);
+
+   BEGIN
+      {$IFNDEF PPC_FPK}                                  { FPK bug }
+      CommandSetChanged := CommandSetChanged OR
+        (CurCommandSet * Commands <> []);                { Set changed flag }
+      {$ENDIF}
+      CurCommandSet := CurCommandSet - Commands;         { Update command set }
+   END;
+
+begin
+   a:=[byte(1)]+[byte(2)];
+end.

tests/tbs0022.pp

@@ -0,0 +1,29 @@
+type
+   tobject = object
+      procedure x;
+      constructor c;
+   end;
+
+procedure a;
+
+  begin
+  end;
+
+procedure tobject.x;
+
+  begin
+  end;
+
+constructor tobject.c;
+
+  begin
+  end;
+
+var
+   p : pointer;
+
+begin
+   p:=@a;
+   p:[email protected];
+   p:[email protected];
+end.

tests/tbs0023.pp

@@ -0,0 +1,47 @@
+type
+   tobject = object
+      a : longint;
+      procedure t1;
+      procedure t2;virtual;
+      constructor init;
+   end;
+
+procedure tobject.t1;
+
+  procedure nested1;
+
+    begin
+       writeln;
+       a:=1;
+    end;
+
+  begin
+  end;
+
+procedure tobject.t2;
+
+  procedure nested1;
+
+    begin
+       writeln;
+       a:=1;
+    end;
+
+  begin
+  end;
+
+constructor tobject.init;
+
+  procedure nested1;
+
+    begin
+       writeln;
+       a:=1;
+    end;
+
+  begin
+  end;
+
+
+begin
+end.

tests/tbs0024.pp

@@ -0,0 +1,24 @@
+
+type
+  charset=set of char;
+
+  trec=record
+     junk : array[1..32] of byte;
+     t    : charset;
+  end;
+
+  var
+     tr    : trec;
+     tp    : ^trec;
+
+
+  procedure Crash(const k:charset);
+
+    begin
+       tp^.t:=[#7..#10]+k;
+    end;
+
+  begin
+     tp:=@tr;
+     Crash([#20..#32]);
+  end.

tests/tbs0025.pp

@@ -0,0 +1,15 @@
+procedure p1;
+type
+  datetime=record
+    junk : string;
+end;
+var
+  dt : datetime;
+begin
+  fillchar(dt,sizeof(dt),0);
+end;
+
+begin
+  P1;
+end.
+

tests/tbs0026.pp

@@ -0,0 +1,22 @@
+const
+  HexTbl : array[0..15] of char=('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
+function HexB(b:byte):string;
+begin
+  HexB[0]:=#2;
+  HexB[1]:=HexTbl[b shr 4];
+  HexB[2]:=HexTbl[b and $f];
+end;
+
+
+
+function HexW(w:word):string;
+begin
+  HexW:=HexB(w shr 8)+HexB(w and $ff);
+end;
+
+
+
+begin
+  HexW($fff);
+end.
+

tests/tbs0027.pp

@@ -0,0 +1,5 @@
+type enumtype = (One, two, three, forty:=40, fifty);
+
+begin
+end.
+

tests/tbs0028.pp

@@ -0,0 +1,10 @@
+type
+   enumtype = (a);
+
+var
+   e : enumtype;
+
+begin
+   writeln(ord(e));
+end.
+

tests/tbs0029.pp

@@ -0,0 +1,10 @@
+type
+  TA = object
+  end;
+
+var
+   P: Pointer;
+
+begin
+   P := pointer(TypeOf(TA));
+end.

tests/tbs0030.pp

@@ -0,0 +1,6 @@
+const
+   a : array[0..1] of real = (1,1);
+
+begin
+end.
+

tests/tbs0031.pp

@@ -0,0 +1,8 @@
+var
+   a : array[boolean] of longint;
+
+begin
+   a[true]:=1234;
+   a[false]:=123;
+end.
+

tests/tbs0032.pp

@@ -0,0 +1,6 @@
+var
+   p : procedure(w : word);
+
+begin
+   p(1234);
+end.

tests/tbs0033.pp

@@ -0,0 +1,13 @@
+var
+   p1 : pchar;
+   p2 : array[0..10] of char;
+   s : string;
+   c : char;
+
+begin
+   p1:='c';
+   s:='c';
+   { this isn't allowed
+   p1:=c;
+   }
+end.

tests/tbs0034.pp

@@ -0,0 +1,16 @@
+{ line numbering problem }
+{ I don't really know how to test this (PM }
+ var i : longint;
+
+begin
+   asm
+      movl %eax,%eax
+      movl %eax,%eax
+      movl %eax,%eax
+      movl %eax,%eax
+      movl %eax,%eax
+      movl %eax,%eax
+      movl %eax,%eax
+   end ;
+   i:=0;
+end.

tests/tbs0035.pp

@@ -0,0 +1,13 @@
+program bug0035;
+
+{Discovered by Daniel Mantione.}
+
+label	hallo;
+
+begin
+   writeln('Hello');
+  begin
+hallo:		{Error message: Incorrect expression.}
+  end;
+  writeln('Hello again');
+end.

tests/tbs0037.pp

@@ -0,0 +1,17 @@
+uses
+   graph,crt;
+
+var
+   gd,gm : integer;
+
+begin
+   gd:=detect;
+   initgraph(gd,gm,'');
+   line(1,1,100,100);
+   readkey;
+   setgraphmode($107);
+   line(100,100,1024,800);
+   readkey;
+   closegraph;
+end.
+   

tests/tbs0038.pp

@@ -0,0 +1,5 @@
+CONST ps : ^STRING = nil;
+
+begin
+end.
+

tests/tbs0039.pp

@@ -0,0 +1,10 @@
+VAR a : BYTE;
+BEGIN
+  a := 1;
+  IF a=0 THEN
+    IF a=1 THEN a:=2
+    ELSE
+  ELSE a:=3;        { "Illegal expression" }
+END.
+
+

tests/tbs0040.pp

@@ -0,0 +1,26 @@
+{ xor operator bug                }
+{ needs fix in pass_1.pas line    }
+{ 706. as well as in the code     }
+{ generator - secondadd()         }
+var
+ b1,b2: boolean;
+Begin
+  b1:=true;
+  b2:=false;
+  If (b1 xor b2) Then
+  begin
+  end
+  else
+    begin
+       writeln('Problem with bool xor');
+       halt;
+    end;
+  b1:=true;
+  b2:=true;
+  If (b1 xor b2) Then
+    begin
+       writeln('Problem with bool xor');
+       halt;
+    end;
+  writeln('No problem found');
+end.

tests/tbs0041.pp

@@ -0,0 +1,8 @@
+var
+ b1: boolean;
+Begin
+  begin
+     If b1 then      { illegal expression }
+  end;
+  while b1 do
+End.

tests/tbs0042.pp

@@ -0,0 +1,11 @@
+{ $OPT= -Rintel }
+Program SomeCrash;
+{ with pp -TDOS -Rintel bug0042.pp              }
+{ I'll try to fix this for next release -- Carl }
+
+Begin
+ asm
+   mov ax,3*-4     { evaluator stack underflow }
+ end;              { due to two operators following each other }
+end.               { this will also happen in att syntax.       }
+

tests/tbs0043.pp

@@ -0,0 +1,32 @@
+{ THE OUTPUT is incorrect but the }
+{ parsing is correct.             }
+{ under nasm output only.         }
+{ works correctly under tasm/gas  }
+{ other problems occur with other }
+{ things in math.inc              }
+{ pp -TDOS -Ratt -Anasm bug0043.pp }
+    procedure frac;
+
+      begin
+	 asm
+	    subl $16,%esp
+	    fnstcw -4(%ebp)
+	    fwait                    { unknown instruction }
+	    movw -4(%ebp),%cx
+	    orw $0x0c3f,%cx
+	    movw %cx,-8(%ebp)
+	    fldcw -8(%ebp)
+	    fwait                    { unknown instruction }
+	    fldl 8(%ebp)
+	    frndint
+	    fsubl 8(%ebp)
+	    fabsl
+	    fclex
+	    fldcw -4(%ebp)
+	    leave
+	    ret $8
+	 end ['ECX'];
+      end;
+
+Begin
+end.

tests/tbs0044.pp

@@ -0,0 +1,16 @@
+ { Problem with nested comments -- as you can probably see } 
+ { but it does give out kind of a funny error output :)    }
+
+ 
+ {$UNDEF VP}
+
+ {$IFDEF Windows} ssss {$ENDIF}      {No Syntax Error}
+
+ {$IFDEF VP}
+      {$D+}{$R+}
+ {$ELSE}
+   {$IFDEF Windows} ssss {$ENDIF}    {Syntax Error at: Col 25 }
+ {$ENDIF}
+
+ BEGIN
+ END.

tests/tbs0045.pp

@@ -0,0 +1,26 @@
+
+TYPE
+  tmyexample =object
+  public
+   constructor init;
+   destructor done; virtual;
+  private
+   procedure mytest;virtual;       { syntax error --> should give only a 
+warning ? }
+  end;
+
+  constructor tmyexample.init;
+  begin
+  end;
+
+  destructor tmyexample.done;
+  Begin
+  end;
+
+  procedure tmyexample.mytest;
+  begin
+  end;
+
+Begin
+end.
+    

tests/tbs0046.pp

@@ -0,0 +1,43 @@
+program test;
+
+{$ifdef fpk}
+{$ifdef go32v2}
+uses
+   dpmiexcp;
+{$endif}
+{$endif}
+
+type byteset = set of byte;
+     bl = record i,j : longint;
+          end;
+const set1 : byteset = [1,50,220];
+      set2 : byteset = [55];
+var i : longint;
+    b : bl;
+
+    function bi : longint;
+
+    begin
+       bi:=b.i;
+    end;
+
+begin
+set1:=set1+set2;
+writeln('set 1 = [1,50,55,220]');
+i:=50;
+if i in set1 then writeln(i,' is in set1');
+i:=220;
+if i in set1 then writeln(i,' is in set1');
+i:=$100+220;
+if i in set1 then writeln(i,' is in set1');
+i:=-35;
+if i in set1 then writeln(i,' is in set1');
+b.i:=50;
+i:=$100+220;
+if i in [50,220] then writeln(i,' is in [50,220]');
+if Bi in [50,220] then writeln(b.i,' is in [50,220]');
+b.i:=220;
+if bi in [50,220] then writeln(b.i,' is in [50,220]');
+B.i:=-36;
+if bi in [50,220] then writeln(B.i,' is in [50,220]');
+end.

tests/tbs0047.pp

@@ -0,0 +1,13 @@
+procedure test;
+
+  begin
+  end;
+
+var
+   p1 : procedure;
+   p2 : pointer;
+
+begin
+   p1:=@test;
+   p2:=@test;
+end.

tests/tbs0048.pp

@@ -0,0 +1,31 @@
+uses
+   graph,crt;
+
+var
+   gd,gm : integer;
+   i,size : longint;
+   p : pointer;
+
+begin
+   gd:=detect;
+   initgraph(gd,gm,'');
+   setcolor(brown);
+   line(0,0,getmaxx,0);
+   readkey;
+   size:=imagesize(0,0,getmaxx,0);
+   getmem(p,size);
+   getimage(0,0,getmaxx,0,p^);
+   cleardevice;
+   for i:=0 to getmaxy do
+     begin
+        putimage(0,i,p^,xorput);
+     end;
+   readkey;
+   for i:=0 to getmaxy do
+     begin
+        putimage(0,i,p^,xorput);
+     end;
+   readkey;
+   closegraph;
+end.
+   

tests/tbs0050.pp

@@ -0,0 +1,19 @@
+function Append : Boolean;
+
+      procedure DoAppend;
+        begin
+           Append := true;
+        end;
+
+begin
+   Append:=False;
+   DoAppend;
+end;
+
+begin
+  If not Append then
+    begin 
+       Writeln('TBS0050 fails');
+       Halt(1);
+    end;
+end.

tests/tbs0051.pp

@@ -0,0 +1,44 @@
+program TestPutP;
+
+uses  crt,graph;
+
+var   gd,gm,gError,yi,i : integer;
+      col: longint;
+      error : word;
+
+BEGIN
+  if paramcount=0 then
+    gm:=$111   {640x480/64K  HiColor}
+  else
+    begin
+       val(paramstr(1),gm,error);
+       if error<>0 then
+         gm:=$111;
+    end;
+  gd:=$FF;
+
+  InitGraph(gd,gm,'');
+  gError := graphResult;
+  IF gError <> grOk
+  THEN begin
+    writeln ('graphDriver=',gd,'  graphMode=',gm,
+    #13#10'Graphics error: ',gError);
+    halt(1);
+  end;
+
+  for i := 0 to 255
+  do begin
+    col := i shl 16 + (i div 2) shl 8 + (i div 3);
+    for yi := 0 to 20 do
+      PutPixel (i,yi,col);
+    SetColor (col);
+    Line (i,22,i,42);
+  end;
+
+  for i:=0 to 255 do
+   if not ColorsEqual(getpixel(i,15),getpixel(i,30)) then
+     Halt(1); 
+  readkey;
+
+  closegraph;
+END.

tests/tbs0052.pp

@@ -0,0 +1,35 @@
+uses 
+  graph;
+
+const
+  Triangle: array[1..3] of PointType = ((X: 50; Y: 100), (X: 100; Y:100),
+    (X: 150; Y: 150));
+  Rect : array[1..4] of PointType = ((X: 50; Y: 100), (X: 100; Y:100),
+    (X: 75; Y: 150), (X: 80; Y : 50));
+  Penta : array[1..5] of PointType = ((X: 250; Y: 100), (X: 300; Y:100),
+    (X: 275; Y: 150), (X: 280; Y : 50), (X:295; Y : 80) );
+
+var Gd, Gm: Integer;
+begin
+  Gd := Detect;
+  InitGraph(Gd, Gm, 'c:\bp\bgi');
+  if GraphResult <> grOk then
+    Halt(1);
+  drawpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle);
+  readln;
+  setcolor(red);
+  fillpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle);
+  readln;
+  SetFillStyle(SolidFill,blue);
+  Bar(0,0,GetMaxX,GetMaxY);
+  Rectangle(25,25,GetMaxX-25,GetMaxY-25);
+  setViewPort(25,25,GetMaxX-25,GetMaxY-25,true);
+  clearViewPort;
+  setcolor(magenta);
+  SetFillStyle(SolidFill,red);
+  fillpoly(SizeOf(Rect) div SizeOf(PointType), Rect);
+  fillpoly(SizeOf(Penta) div SizeOf(PointType), Penta);
+  graphdefaults;
+  readln;
+  CloseGraph;
+end.

tests/tbs0053.pp

@@ -0,0 +1,15 @@
+procedure abc(var a : array of char);
+
+  begin
+     // error: a:='asdf';
+  end;
+
+var
+   c : array[0..10] of char;
+
+begin
+   abc(c);
+   writeln(c);
+   // error: writeln(a);
+end.
+   

tests/tbs0054.pp

@@ -0,0 +1,6 @@
+var
+   wb : wordbool;
+   wl : longbool;
+
+begin
+end.

tests/tbs0055.pp

@@ -0,0 +1,15 @@
+type
+   tarraysingle = array[0..1] of single;
+
+procedure test(var a : tarraysingle);
+
+var   
+   i,j,k : integer;
+
+begin
+   a[i]:=a[j]-a[k];
+end;
+
+begin
+end.
+

tests/tbs0056.pp

@@ -0,0 +1,14 @@
+PROGRAM ShowBug;
+
+(* This will compile
+VAR N, E: Integer;*)
+
+(* This will NOT compile*)
+VAR N, E: LongInt;
+
+BEGIN
+   E := 2;
+   WriteLn(E);
+   N := 44 - E;
+   WriteLn(N);
+END.

tests/tbs0057.pp

@@ -0,0 +1,18 @@
+uses
+   graph,crt;
+        
+var
+   gd,gm : integer;
+
+begin
+   gd:=detect;
+   gm:=$103;
+   initgraph(gd,gm,'');
+   line(1,1,100,100);
+   readkey;
+   closegraph;
+   initgraph(gd,gm,'');
+   line(100,100,1,100);
+   readkey;
+   closegraph;
+end.

tests/tbs0058.pp

@@ -0,0 +1,9 @@
+{$r+}
+var
+   a1 : array[0..1,0..1] of word;
+   a2 : array[0..1,0..1] of longint;
+   i,j,l,n : longint;
+
+begin
+   a1[i,j]:=a2[l,n];
+end.

tests/tbs0059.pp

@@ -0,0 +1,9 @@
+Program ConstBug;
+
+Const
+ S = ord('J');
+ t: byte = ord('J');
+
+
+Begin
+end.

tests/tbs0061.pp

@@ -0,0 +1,8 @@
+var
+   r : double;
+   s : string;
+
+begin
+   r:=1234.0;
+   str(r,s);
+end.

tests/tbs0062.pp

@@ -0,0 +1,9 @@
+Program Bug0062;
+
+
+var
+ myvar:boolean;
+Begin
+ { by fixing this we also start partly implementing LONGBOOL/WORDBOOL }
+ myvar:=boolean(1);      { illegal type conversion }
+end.

tests/tbs0063.pp

@@ -0,0 +1,13 @@
+{ may also crash/do weird error messages with the compiler }
+var
+ min: char;
+ max: char;
+ i: char;
+begin
+ min:='c';
+ max:='z';
+ if i in [min..max] then
+ Begin
+ end;
+end.
+

tests/tbs0064.pp

@@ -0,0 +1,15 @@
+var
+ i: byte;
+ j: integer;
+ c: char;
+Begin
+  case i of
+  Ord('x'): ;
+  end;
+  case j of
+  Ord('x'): ;
+  end;
+  case c of
+  Chr(112): ;
+  end;
+end.

tests/tbs0065.pp

@@ -0,0 +1,10 @@
+Program Example27;
+
+{ Program to demonstrate the Frac function. }
+
+Var R : Real;
+
+begin
+  Writeln (Frac (123.456):0:3);  { Prints  O.456 }
+  Writeln (Frac (-123.456):0:3); { Prints -O.456 }
+end.

tests/tbs0066.pp

@@ -0,0 +1,10 @@
+Program Example54;
+
+{ Program to demonstrate the Round function. }
+
+begin
+  Writeln (Round(123.456));  { Prints 124  }
+  Writeln (Round(-123.456)); { Prints -124 }
+  Writeln (Round(12.3456));  { Prints 12   }
+  Writeln (Round(-12.3456)); { Prints -12  }
+end.

tests/tbs0067.pp

@@ -0,0 +1,18 @@
+unit tbs0067;
+
+interface
+
+type
+  tlong=record
+    a : longint;
+  end;
+
+procedure p(var t:tlong);
+
+implementation
+
+procedure p(var t:tlong);
+begin
+end;
+
+end.

tests/tbs0067b.pp

@@ -0,0 +1,27 @@
+unit tbs0067b;
+
+interface
+
+
+type
+  tlong=record
+    a : longint;
+  end;
+
+procedure p(var l:tlong);
+
+implementation
+
+uses tbs0067;
+
+{ the tlong parameter is taken from unit bug0067,
+  and not from the interface part of this unit.
+  setting the uses clause in the interface part 
+  removes the problem }
+
+procedure p(var l:tlong);
+begin
+  tbs0067.p(tbs0067.tlong(l));
+end;
+
+end.

tests/tbs0068.pp

@@ -0,0 +1,9 @@
+program bug0068;
+
+var
+  p : pointer;
+  l  : longint;
+begin
+  l:=Ofs(p); { Ofs returns a pointer type !? }
+  
+end.

tests/tbs0069.pp

@@ -0,0 +1,25 @@
+Unit tbs0069;
+
+Interface
+
+Procedure MyTest;Far;         { IMPLEMENTATION expected error. }
+
+{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL  }
+{ Therefore the bugfix should only be for the FAR keyword.    }
+(* Procedure MySecondTest;Near;                             *)
+
+Implementation
+
+{ near and far are not allowed here, but maybe we don't care since they are ignored by }
+{ FPC.                                                                                 }
+Procedure MyTest;
+Begin
+end;
+
+Procedure MySecondTest;
+Begin
+end;
+
+
+
+end.

tests/tbs0070.pp

@@ -0,0 +1,10 @@
+Program Test;
+
+type
+  myenum = (YES,NO,MAYBE);
+var
+ myvar:set of myenum;
+Begin
+ Include(myvar,Yes);
+ Exclude(myvar,No);
+end.

tests/tbs0071.pp

@@ -0,0 +1,5 @@
+program tbs0071;
+
+begin
+  writeln ('
+end.

tests/tbs0072.pp

@@ -0,0 +1,15 @@
+type
+   tarraysingle = array[0..1] of single;
+
+procedure test(var a : tarraysingle);
+
+var   
+   i,j,k : integer;
+
+begin
+   a[i]:=a[j]-a[k];
+end;
+
+begin
+end.
+

tests/tbs0073.pp

@@ -0,0 +1,30 @@
+Unit tbs0073;
+
+Interface
+
+
+Procedure MyTest;Far;         { IMPLEMENTATION expected error. }
+
+{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL  }
+{ Therefore the bugfix should only be for the FAR keyword.    }
+ Procedure MySecondTest;
+
+Implementation
+
+{ near and far are not allowed here, but maybe we don't care since they are ignored by }
+{ FPC.                                                                                 }
+Procedure MyTest;
+Begin
+end;
+
+
+
+Procedure MySecondTest;Far;
+Begin
+end;
+
+
+
+
+
+end.

tests/tbs0074.pp

@@ -0,0 +1,28 @@
+type
+  tmyobject = object
+    constructor init;
+    procedure callit; virtual;
+    destructor done; virtual;
+  end;
+
+
+  constructor tmyobject.init;
+  Begin
+  end;
+
+  destructor tmyobject.done;
+  Begin
+  end;
+
+  procedure tmyobject.callit;
+  Begin
+   WriteLn('Hello...');
+  end;
+
+  var
+   obj: tmyobject;
+  Begin
+    obj.init;
+    obj.callit;
+{    obj.done;}
+  end.

tests/tbs0075.pp

@@ -0,0 +1,31 @@
+Unit tbs0075;
+
+Interface
+
+
+Procedure MyTest;Far;         { IMPLEMENTATION expected error. }
+
+{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL  }
+{ Therefore the bugfix should only be for the FAR keyword.    }
+ Procedure MySecondTest;
+
+Implementation
+
+{ near and far are not allowed here, but maybe we don't care since they are ignored by }
+{ FPC.                                                                                 }
+Procedure MyTest;
+Begin
+end;
+
+Procedure MySecondTest;Far;Forward;
+
+
+Procedure MySecondTest;Far;
+Begin
+end;
+
+
+
+
+
+end.

tests/tbs0076.pp

@@ -0,0 +1,24 @@
+program bug0076;
+
+{Generates wrong code when compiled with output set to intel asm.
+
+ Reported from mailinglist by Vtech Kavan.
+ 
+ 15 Januari 1998, Daniel Mantione}
+
+type  TVtx2D = record x,y:longint end;
+
+var  Vtx2d:array[0..2] of TVtx2D;
+
+function SetupScanLines(va,vb,vc:word):single;
+var dx3d,dx2d,dy2d,dz,ex3d,ex2d,ez:longint;
+    r:single;
+begin
+ dy2d := Vtx2d[vb].y;
+ r    := (dy2d-Vtx2d[va].y);     {this line causes error!!!!!!!!!!!!!!!!!!!}
+end;
+
+begin
+ SetupScanLines(1,2,3);
+end.
+

tests/tbs0077.pp

@@ -0,0 +1,9 @@
+uses
+   tbs0077b;
+
+begin
+   b:=89;
+   writeln(a);
+end.
+
+

tests/tbs0077b.pp

@@ -0,0 +1,11 @@
+unit tbs0077b;
+
+  interface
+
+    var
+       a : longint;
+       b : longint absolute a;
+
+  implementation
+
+end.

tests/tbs0078.pp

@@ -0,0 +1,8 @@
+{ $OPT=-Rintel }
+{ shows error with asm_size_mismatch }
+Begin
+ asm
+   mov eax, 2147483647 
+   mov eax, 2000000000
+ end;
+end.

tests/tbs0079.pp

@@ -0,0 +1,19 @@
+{ $OPT= -Rintel }
+
+procedure nothing(x,y: longint);assembler;
+asm
+  mov eax,x
+  mov ebx,y
+end;
+
+
+{procedure nothing(x,y: longint);
+begin
+ asm
+  mov eax,x
+  mov ebx,y
+ end;
+end; }
+
+Begin
+end.

tests/tbs0080.pp

@@ -0,0 +1,8 @@
+program bug0080;
+
+type 
+
+ tHugeArray = array [ 1 .. High(Word) ] of byte;
+
+begin
+end.

tests/tbs0081.pp

@@ -0,0 +1,7 @@
+program bug0081;
+
+const
+   EOL : array [1..2] of char = #13 + #10;
+   
+begin
+end.

tests/tbs0082.pp

@@ -0,0 +1,29 @@
+Unit tbs0082;
+
+interface
+
+Type T = OBject
+      Constructor Init;
+      Destructor Free; virtual;
+      Destructor Destroy; virtual;
+      end;
+      
+implementation
+      
+constructor T.INit;
+
+begin
+end;
+
+Destructor t.Free;
+
+begin
+end;
+
+Destructor t.Destroy;
+
+begin
+end;
+
+
+end.

tests/tbs0083.pp

@@ -0,0 +1,8 @@
+
+var
+   s1 : set of char;
+   c1,c2,c3 : char;
+
+begin
+   s1:=[c1..c2,c3];
+end.

tests/tbs0084.pp

@@ -0,0 +1,13 @@
+
+{ Basic Pascal principles gone done the drain... !!!! }
+var
+ v: word;
+ w: shortint;
+ z: byte;
+ y: integer;
+Begin
+ y:=64000;
+ z:=32767;
+ w:=64000;
+ v:=-1;
+end.

tests/tbs0090.pp

@@ -0,0 +1,10 @@
+{$X+}
+var
+ mystr : array[0..4] of char;
+
+Begin
+  if mystr = #0#0#0#0 then
+  Begin
+  end;
+  mystr:=#0#0#0#0;
+end.

tests/tbs0091.pp

@@ -0,0 +1,23 @@
+{ Page 22 of The Language Guide of Turbo Pascal }
+var
+ t: byte;
+const
+  a = Trunc(1.3);
+  b = Round(1.6);
+  c = abs(-5);
+  ErrStr = 'Hello!';
+  d = Length(ErrStr);
+  e = Lo($1234);
+  f = Hi($1234);
+  g = Chr(34);
+  h = Odd(1);
+  i = Ord('3');
+  j = Pred(34);
+  l = Sizeof(t);
+  m = Succ(9);
+  n = Swap($1234);
+  o = ptr(0,0);
+Begin
+end.
+
+

tests/tbs0092.pp

@@ -0,0 +1,10 @@
+{The unfixable bug. Maybe we get an idea when we keep looking at it.
+ Daniel Mantione 5 februari 1998.}
+
+const
+        a:1..4=2;               {Crash 1.}
+        b:set of 1..4=[2,3];    {Also crashes, but is the same bug.}
+
+begin
+   writeln(a);
+end.

tests/tbs0093.pp

@@ -0,0 +1,18 @@
+{ Two cardinal type bugs }
+var
+  c : cardinal;
+  l : longint;
+  b : byte;
+  s : shortint;
+  w : word;
+begin
+  b:=123;
+  w:=s;
+  l:=b;
+  c:=b;		{generates movzbl %eax,%edx instead of movzbl %al,%edx}
+
+  c:=123;
+  writeln(c);	{Shows '0' outline right! instead of '123' outlined left}
+  c:=$7fffffff;
+  writeln(c);	{Shows '0' outline right! instead of '123' outlined left}
+end.

tests/tbs0094.pp

@@ -0,0 +1,5 @@
+begin
+  case textrec(l).mode of
+   1 ;
+  end;
+end.

tests/tbs0095.pp

@@ -0,0 +1,15 @@
+var
+  ch : char;
+begin
+  ch:=#3;
+  case ch of
+   #0..#31 : ;
+  else
+   writeln('bug');
+  end;
+  case ch of
+   #0,#1,#3 : ;
+  else
+   writeln('bug');
+  end;
+end.

tests/tbs0096.pp

@@ -0,0 +1,24 @@
+type
+   TParent = object
+   end;
+
+   PParent = ^TParent;
+
+   TChild = object(TParent)
+   end;
+
+procedure aProc(const x : TParent );
+begin
+end;
+
+procedure anotherProc(var x : TParent );
+begin
+end;
+
+var
+   y : TChild;
+
+   begin
+      aProc(y);
+      anotherProc(y);
+   end.

tests/tbs0097.pp

@@ -0,0 +1,39 @@
+{
+  This compiles fine with FPC, but not with Bp7 see 2 comments
+}
+
+type
+  t=object
+    s : string;      { No ; needed ? }
+    procedure p;
+  end;
+
+  t2=object(t)
+    procedure p1(p : string); 
+  end;
+
+procedure t2.p1(p : string);
+
+  begin
+  end;
+
+procedure t.p;
+
+var
+  s : longint;      { Not allowed with BP7 }
+  x : longint;
+
+procedure nested;
+
+  var
+     s : longint;
+
+  begin
+  end;
+
+begin
+end;
+
+
+begin
+end.

tests/tbs0098.pp

@@ -0,0 +1,45 @@
+program Test;
+{ Show how to seek to an OFFSET (not a line number) in a textfile, }
+{ without using asm. Arne de Bruijn, 1994, PD }
+uses Dos; { For TextRec and FileRec }
+var
+ F:text;
+ L:longint;
+ S:string;
+begin
+ assign(F,'TEST.PAS');                 { Assign F to itself }
+ reset(F);                             { Open it (as a textfile) }
+ ReadLn(F);                            { Just read some lines }
+ ReadLn(F);
+ ReadLn(F);
+ FileRec((@F)^).Mode:=fmInOut;         { Set to binary mode }
+  { (The (@F)^ part is to let TP 'forget' the type of the structure, so }
+  {  you can type-caste it to everything (note that with and without (@X)^ }
+  {  can give a different value, longint(bytevar) gives the same value as }
+  {  bytevar, while longint((@bytevar)^) gives the same as }
+  {  longint absolute Bytevar (i.e. all 4 bytes in a longint are readed }
+  {  from memory instead of 3 filled with zeros))) }
+ FileRec((@F)^).RecSize:=1;            { Set record size to 1 (a byte)}
+ L:=(FilePos(File((@F)^))-TextRec(F).BufEnd)+TextRec(F).BufPos;
+{... This line didn't work the last time I tried, it chokes on the "File"
+typecasting thing.}
+
+  { Get the fileposition, subtract the already readed buffer, and add the }
+  { position in that buffer }
+ TextRec(F).Mode:=fmInput;             { Set back to text mode }
+ TextRec(F).BufSize:=SizeOf(TextBuf);  { BufSize overwritten by RecSize }
+                                       { Doesn't work with SetTextBuf! }
+ ReadLn(F,S);                          { Read the next line }
+ WriteLn('Next line:',S);              { Display it }
+ FileRec((@F)^).Mode:=fmInOut;         { Set to binary mode }
+ FileRec((@F)^).RecSize:=1;            { Set record size to 1 (a byte)}
+ Seek(File((@F)^),L);                  { Do the seek }
+{... And again here.}
+
+ TextRec(F).Mode:=fmInput;             { Set back to text mode }
+ TextRec(F).BufSize:=SizeOf(TextBuf);  { Doesn't work with SetTextBuf! }
+ TextRec(F).BufPos:=0; TextRec(F).BufEnd:=0; { Reset buffer counters }
+ ReadLn(F,S);                          { Show that it worked, the same }
+ WriteLn('That line again:',S);        { line readed again! }
+ Close(F);                             { Close it }
+end.

tests/tbs0099.pp

@@ -0,0 +1,7 @@
+
+{$R+}
+var w:word;
+    s:Shortint;
+begin
+  w := s;
+end.

tests/tbs0100.pp

@@ -0,0 +1,7 @@
+unit u;
+interface
+uses dos;
+implementation
+uses dos;             { Not Allowed in BP7}
+end.
+

tests/tbs0101.pp

@@ -0,0 +1,18 @@
+Unit XYZ;
+
+Interface
+
+ Procedure MyProc(V: Integer);
+
+
+Implementation
+ 
+ Procedure MyProc(Y: Integer);
+ Begin
+ end;
+
+
+end.
+
+
+

tests/tbs0102.pp

@@ -0,0 +1,16 @@
+
+unit bug0102;
+  interface
+
+  implementation
+
+    procedure int_help_constructor;
+
+      begin
+         asm
+            movem.l d0-a7,-(sp)
+         end;
+      end;
+
+
+  end.

tests/tbs0103.pp

@@ -0,0 +1,8 @@
+
+Var
+ out: boolean;
+ int: byte;
+Begin
+ { savesize is different! }
+ out:=boolean((int AND $20) SHL 4);
+end.

tests/tbs0104.pp

@@ -0,0 +1,13 @@
+uses
+   dpmiexcp;
+{ Two cardinal type bugs }
+var
+  c : cardinal;
+begin
+  c:=$80000000;
+  writeln(c);
+  c:=$80001234;
+  writeln(c);
+  c:=$ffffffff;
+  writeln(c); 
+end.

tests/tbs0105.pp

@@ -0,0 +1,15 @@
+{$R+}
+{ BOUND check error... I don't think this is a code generator error }
+{ but an error because the type casting is not considered at all!   }
+{ Must be compiled with -Cr                                         }
+
+
+Var
+ Sel: Word;
+ v: longint;
+Begin
+ v:=$00ffffff;
+ Sel:=word(v);
+ writeln(sel);
+ sel:=v;
+end.

tests/tbs0106.pp

@@ -0,0 +1,11 @@
+
+{ I think this now occurs with most type casting... }
+{ I think type casting is no longer considered??     }
+
+Var
+ Sel: Word;
+ Sel2: byte;
+Begin
+ Sel:=word($7fffffff);
+ Sel2:=byte($7fff);
+end.

tests/tbs0107.pp

@@ -0,0 +1,28 @@
+{ PAGE FAULT PROBLEM ... TEST UNDER DOS ONLY! Not windows... }
+{ -Cr -g flags                                               }
+
+Program Test1;
+
+uses
+   dpmiexcp;
+type
+ myObject = object
+   constructor init;
+   procedure v;virtual;
+ end;
+
+ constructor myobject.init;
+ Begin
+ end;
+
+ procedure myobject.v;
+ Begin
+  WriteLn('Hello....');
+ end;
+
+var
+ my: myobject;
+Begin
+ my.init;
+ my.v;
+end.

tests/tbs0108.pp

@@ -0,0 +1,5 @@
+uses
+  dos,
+  ;
+begin
+end.

tests/tbs0109.pp

@@ -0,0 +1,9 @@
+Type T = (aa,bb,cc,dd,ee,ff,gg,hh);
+     Tset = set of t;
+
+Var a: Tset;
+
+Begin
+  If (aa in a^) Then begin end;
+  {it seems that correct code is generated, but the syntax is wrong}
+End.

tests/tbs0110.pp

@@ -0,0 +1,7 @@
+uses aasm;
+
+Begin
+  Case Pai(hp1)^.typ Of
+    ait_instruction:
+  End
+End.

tests/tbs0111.pp

@@ -0,0 +1,13 @@
+var
+  f : file of word;
+  i : word;
+  buf : string;
+begin
+  assign(f,'test');
+  reset(f);
+  blockread(f,buf[1],sizeof(buf),i);    { This is not allowed in BP7 }
+  buf[0]:=chr(i);
+  close(f);
+  writeln(i);
+  writeln(buf);
+end.

tests/tbs0112.pp

@@ -0,0 +1,21 @@
+type
+  TextBuf=array[0..127] of char;
+  TextRec=record
+    BufPtr : ^textbuf;
+    BufPos : word;
+  end;
+
+Function ReadNumeric(var f:TextRec;var s:string;base:longint):Boolean;
+{
+  Read Numeric Input, if buffer is empty then return True
+}
+begin
+  while ((base>=10) and (f.BufPtr^[f.BufPos] in ['0'..'9'])) or
+        ((base=16) and (f.BufPtr^[f.BufPos] in ['A'..'F'])) or
+        ((base=2) and (f.BufPtr^[f.BufPos] in ['0'..'1'])) do
+   Begin
+   End;
+end;
+
+begin
+end.

tests/tbs0113.pp

@@ -0,0 +1,13 @@
+program test;
+
+type pRecord = ^aRecord;
+     aRecord = record
+                     next : pRecord;
+                     a, b, c : integer;
+               end;
+
+const rec1 : aRecord = (next : nil; a : 10; b : 20; c : 30);
+      rec2 : aRecord = (next : @rec1; a : 20; b : 30; c : 40);
+
+begin
+end.

tests/tbs0114.pp

@@ -0,0 +1,3 @@
+begin
+ write{ln}(0.997:0:2);
+end.

tests/tbs0115.pp

@@ -0,0 +1,10 @@
+var
+   c : comp;
+
+begin
+   c:=1234;
+   writeln(c);
+   readln(c);
+   writeln(c);
+end.
+   

tests/tbs0116.pp

@@ -0,0 +1,9 @@
+Procedure test;
+{compile with -Og to show bug}
+
+Var a: Array[1..4000000] of longint;
+Begin
+End;
+
+Begin
+End.

tests/tbs0117.pp

@@ -0,0 +1,21 @@
+var
+ i: word;
+ j: integer;
+Begin
+ i:=65530;
+ i:=i+1;     { CF check  }
+ i:=i-1;
+ i:=i*5;
+ i:=i/5;
+ i:=i shl 5;
+ i:=i shr 5;
+ Inc(i);     { no check  }
+ j:=32765;   { OV check  }
+ j:=j+1;
+ inc(j);
+ j:=j-1;
+ j:=j*5;
+ j:=j div 5;
+ j:=j shl 5;
+ j:=j shr 5;
+end.

tests/tbs0118.pp

@@ -0,0 +1,11 @@
+program Test1;
+
+  type
+    ExampleProc = procedure;
+
+  var
+    Eg: ExampleProc;
+
+  begin
+    Eg := nil;  { This produces a compiler error }
+  end.

tests/tbs0119.pp

@@ -0,0 +1,44 @@
+program ObjTest;
+   uses crt;
+
+   type
+     ObjectA = object
+       procedure Greetings;
+       procedure DoIt;
+     end;
+     ObjectB = object (ObjectA)
+       procedure Greetings;
+       procedure DoIt;
+     end;
+
+   procedure ObjectA.Greetings;
+   begin
+     writeln('  A');
+   end;
+   procedure ObjectA.DoIt;
+   begin
+     writeln('A ');
+     Greetings;
+   end;
+
+   procedure ObjectB.Greetings;
+   begin
+     writeln('  B');
+   end;
+   procedure ObjectB.DoIt;
+   begin
+     writeln('B');
+     Greetings;
+   end;
+
+   var
+     A: ObjectA;
+     B: ObjectB;
+
+   begin
+     A.DoIt;
+     B.DoIt;
+     writeln; writeln('Now doing it directly:');
+     A.Greetings;
+     B.Greetings;
+   end.

tests/tbs0120.pp

@@ -0,0 +1,9 @@
+type
+   te = (enum);
+
+var
+   e : te;
+
+begin
+   inc(e);
+end.

tests/tbs0121.pp

@@ -0,0 +1,18 @@
+{$R+}
+var
+
+  c : cardinal;
+  i : integer;
+  w : word;
+  b : byte;
+  si : shortint;
+
+begin
+  w:=c;
+  i:=c;
+  b:=c;
+  b:=si;
+end.
+
+
+

tests/tbs0122.pp

@@ -0,0 +1,9 @@
+
+function f:longint;
+begin
+  exit(1);
+end;
+
+begin
+  writeln(f);
+end.

tests/tbs0123.pp

@@ -0,0 +1,6 @@
+{$I386_INTEL}
+begin
+   asm
+      SHRD [ESI-8], EAX, CL
+   end;
+end.

tests/tbs0124.pp

@@ -0,0 +1,11 @@
+{ Compile with -Rintel switch }
+var
+ l : longint;
+begin
+ { problem here is that l is replaced by BP-offset     }
+ { relative to stack, and the parser thinks all wrong  }
+ { because of this.                                    }
+ asm
+   mov eax, [eax*4+l]    
+ end;
+end. 

tests/tbs0125.pp

@@ -0,0 +1,13 @@
+uses
+crt;
+var
+i:integer;
+begin
+clrscr;
+textcolor(blue);
+writeln('ole');
+textcolor(red);
+readln(i);
+writeln('rasmussen');
+writeln(i);
+end.