* new bug

tests/webtbf/tw3275.pp

@@ -0,0 +1,18 @@
+{ %fail }
+
+{ Source provided for Free Pascal Bug Report 3275 }
+{ Submitted by "Vincent Snijders" on  2004-08-27 }
+{ e-mail: vslist@zonnet.nl }
+program bug3275;
+
+var
+  b: boolean;
+  i: integer;
+  j: integer;
+
+begin
+  b := false;
+  i := 4;
+  j := 5;
+  b := b or i <> j;
+end.

tests/webtbf/tw3294.pp

@@ -0,0 +1,16 @@
+{ %fail }
+
+{ Source provided for Free Pascal Bug Report 3294 }
+{ Submitted by "marco" on  2004-09-05 }
+{ e-mail:  }
+
+{$mode delphi}
+
+var i : integer;
+
+begin
+  for i:=0 to 10 do
+    begin
+      i:=20;
+    end;
+end.

tests/webtbs/tw3212.pp

@@ -0,0 +1,26 @@
+{ Source provided for Free Pascal Bug Report 3212 }
+{ Submitted by "Marc Weustink" on  2004-07-15 }
+{ e-mail: marc@freepascal.org }
+program conststring;
+
+{$mode objfpc}
+{$H+}
+
+const
+  C1: String = 'bla';
+
+procedure X;
+const
+  C: String = 'bla';
+begin
+  C:='bla';
+  C:='bla'+C;
+  WriteLN('"',C,'"');
+  if C<>'blabla' then
+    halt(1);
+end;
+
+begin
+  X;
+  X;
+end.

tests/webtbs/tw3272.pp

@@ -1,17 +1,17 @@
-var i: integer;
-    err : boolean;
-begin
-  for i:= -1 to -2 do
-    begin
-      writeln (i);
-      err:=true;
-    end;
- writeln;
- for i:= 1 to 0 do
-    begin
-      writeln (i);
-      err:=true;
-    end;
-  if err then
-    halt(1);
-end.
+var i: integer;
+    err : boolean;
+begin
+  for i:= -1 to -2 do
+    begin
+      writeln (i);
+      err:=true;
+    end;
+ writeln;
+ for i:= 1 to 0 do
+    begin
+      writeln (i);
+      err:=true;
+    end;
+  if err then
+    halt(1);
+end.

tests/webtbs/tw3274.pp

@@ -0,0 +1,22 @@
+{ %target=i386 }
+
+{ Source provided for Free Pascal Bug Report 3274 }
+{ Submitted by "Frank Kintrup" on  2004-08-27 }
+{ e-mail: frank.kintrup@gmx.de }
+{$MODE Delphi}
+{$ASMODE Intel}
+
+var
+  X : Integer;
+  B : byte;
+begin
+   X:=10;
+   asm
+        LEA  ESI, X
+        MOV  AL, Byte([ESI])
+        MOV  B, AL
+   end;
+   writeln(b);
+   if b<>10 then
+     halt(1);
+end.

tests/webtbs/tw3292.pp

@@ -0,0 +1,48 @@
+{ Source provided for Free Pascal Bug Report 3292 }
+{ Submitted by "Vincent Snijdes" on  2004-09-03 }
+{ e-mail: vslist@zonnet.nl }
+program bug3292;
+
+{$ifdef fpc}{$mode objfpc}{$H+}{$endif}
+
+uses
+  Classes, uw3292a;
+
+type
+  TDerived = class(TMiddle)
+  private
+    procedure a(var m); message 1;
+    procedure b; override;
+  end;
+
+{ TDerived }
+
+procedure TDerived.a(var m);
+begin
+  writeln('A; In TDerived');
+  inc(acnt);
+  inherited a(m);
+end;
+
+procedure TDerived.b;
+begin
+  writeln('B: In TDerived');
+  inc(bcnt);
+  inherited b;
+end;
+
+var
+  o: TDerived;
+  m: longint;
+
+begin
+  o := TDerived.Create;
+  acnt:=0;
+  bcnt:=0;
+  o.a(m);
+  o.b;
+  if acnt<>2 then
+    halt(1);
+  if bcnt<>2 then
+    halt(1);
+end.

tests/webtbs/tw3294a.pp

@@ -0,0 +1,14 @@
+{ Source provided for Free Pascal Bug Report 3294 }
+{ Submitted by "marco" on  2004-09-05 }
+{ e-mail:  }
+
+{$mode tp}
+
+var i : integer;
+
+begin
+  for i:=0 to 10 do
+    begin
+      i:=20;
+    end;
+end.

tests/webtbs/tw3298.pp

@@ -0,0 +1,24 @@
+{ %target=i386 }
+
+{ Source provided for Free Pascal Bug Report 3298 }
+{ Submitted by "marco" on  2004-09-07 }
+{ e-mail:  }
+{$mode delphi}
+
+const
+  OffsetArray: array[0..3] of cardinal = ($FFFFFFFC,$FFFFFFFD,$FFFFFFFE,$FFFFFFFF);
+
+procedure MMXUnpacked;
+var
+  l : cardinal;
+begin
+ asm
+  mov esi, offset OffsetArray[2]
+  mov eax,[esi]
+  mov l,eax
+ end;
+ if l<>$FFFFFFFE then
+   halt(1);
+end;
+begin
+end.

tests/webtbs/tw3301.pp

@@ -0,0 +1,43 @@
+{ Source provided for Free Pascal Bug Report 3301 }
+{ Submitted by "Alexey Barkovoy" on  2004-09-07 }
+{ e-mail: clootie@ixbt.com }
+{$APPTYPE CONSOLE}
+{$mode delphi}
+
+uses SysUtils;
+
+var
+  err : boolean;
+
+procedure WideConstArray(FS: String; const Args: array of const);
+var i: Integer; S: String;
+begin
+  for i:= 0 to High(Args) do
+  begin
+    if (Args[i].Vtype = vtPointer) or
+       (Args[i].Vtype = vtObject) or
+       (Args[i].Vtype = vtClass) or
+       (Args[i].Vtype = vtVariant)
+      then // == 5
+    begin
+      WriteLn('BAD:  ', i, ' parameter is detected as a pointer one - (',
+         Args[i].Vtype, ')');
+      err:=true;
+    end else
+      WriteLn(':  ', i, ' parameter is detected as a some other type - (',
+         Args[i].Vtype, ')');
+  end;
+  S:= Format(FS, Args);
+  WriteLn;
+  WriteLn('Result is:', S);
+end;
+
+var
+  w1: WideString;  wc: PWideChar;  cc: WideChar;  S: String;  ch: Char;  pch, pch2: PChar;
+begin
+  w1 := 'Some other wide string';  wc:= @w1[1];  S:= 'String1';  ch:= 'c';  pch:= @ch;  pch2:= @s[1];  cc:= 'Z';
+  // BAD: This will raise exception?
+  WideConstArray('%s, %s, %s, %s, %s',    [WideString('wide string'), w1, cc, wc, PWideChar(wc)]);
+  if err then
+    halt(1);
+end.

tests/webtbs/tw3309.pp

@@ -0,0 +1,27 @@
+{ Source provided for Free Pascal Bug Report 3309 }
+{ Submitted by "Tom Verhoeff" on  2004-09-10 }
+{ e-mail: T.Verhoeff@tue.nl }
+program ReadSubrange;
+  { Demonstrates bug in 1.9.5 when reading into a subrange of Integer }
+
+const
+  MaxValue = 65536; { exceeds 16 bit range }
+
+type
+  Subrange = 0 .. MaxValue;
+
+var
+  i: Subrange;
+  c: cardinal;
+
+begin
+  write ( 'Type an integer in the range 0 .. ', MaxValue, ': ' );
+  // Only compile, don't run
+  i:=1;
+  if i=2 then
+    begin
+      readln ( c );
+      readln ( i );
+    end;
+ writeln ( 'i = ', i );
+end.

tests/webtbs/uw3292a.pp

@@ -0,0 +1,55 @@
+unit uw3292a;
+
+{$ifdef fpc}{$mode objfpc}{$H+}{$endif}
+
+interface
+
+type
+  TBase = class
+  protected
+    procedure a(var msg); message 1;
+    procedure b; virtual;
+  end;
+
+  TMiddle = class(TBase)
+  private
+    procedure a(var msg); message 1;
+    procedure b;override;
+  end;
+
+var
+  acnt,bcnt : longint;
+
+implementation
+
+{ TBase }
+
+procedure TBase.a(var msg);
+begin
+  writeln('A: In TBase');
+  inc(acnt);
+end;
+
+procedure TBase.b;
+begin
+  writeln('B: In TBase');
+  inc(bcnt);
+end;
+
+{ TMiddle }
+
+procedure TMiddle.a(var msg);
+begin
+  writeln('A: In TMiddle');
+  inc(acnt);
+  inherited a(msg);
+end;
+
+procedure TMiddle.b;
+begin
+  writeln('B: In TMiddle');
+  inc(bcnt);
+  inherited b;
+end;
+
+end.