+ new bugs converted

tests/makefile

@@ -184,8 +184,7 @@ clean_fail :
 	-rm $(addsuffix .ref,$(TF_FAIL_LIST)) 
 	-rm log 
 
-again : clean_fail $(addsuffix .res,$(TS_FAIL_LIST)) \
-	$(addsuffix .ref,$(TF_FAIL_LIST)) 
+again : clean_fail $(addsuffix .res,$(TS_FAIL_LIST)) $(addsuffix .ref,$(TF_FAIL_LIST)) 
 	grep fails log
 
 all_compilations : allts alltbs alltf alltbf allto alltest alltesi alltis
@@ -221,7 +220,10 @@ info :
 	@echo run \'make tesiexec\' to test executables 
 	@echo that require interactive mode
 # $Log$
-# Revision 1.9  1998-11-10 11:13:07  pierre
+# Revision 1.10  1999-01-15 17:41:58  pierre
+#  + new bugs converted
+#
+# Revision 1.9  1998/11/10 11:13:07  pierre
 #  * more tests
 #
 # Revision 1.8  1998/10/28 09:52:26  pierre

tests/tbf0196.pp

@@ -0,0 +1,9 @@
+Program bug0195;
+
+function a;
+begin
+end;
+
+begin
+  a
+end.

tests/tbf0197.pp

@@ -0,0 +1,13 @@
+
+var i : DWord;
+    c1, c2 : comp;
+
+begin
+     c1 := 20000; c2 := 100;
+     i := 0;
+     repeat
+           inc(i);
+           c1 := (abs(3*c1)-c2) < c2;   { notice this !!! :) :) }
+     until (i > 1000);
+     Writeln(c1);
+end.

tests/tbs0140.pp

@@ -1,4 +1,4 @@
-unit bug0140;
+unit tbs0140;
 
 { 
  The first compilation runs fine. 

tests/tbs0183.pp

@@ -0,0 +1,27 @@
+program Internal_Error_10;
+ 
+type
+  PBug = ^TBug;
+  TBug = array[1..1] of boolean;
+ 
+var
+  Left : PBug;
+  test : longint;
+ 
+begin
+  New(left);
+  test := 1;
+ 
+{ following shows internal error 10 only if the
+ 
+    array index is a var on both sides
+  ( if either is a constant then it compiles fine, error only occurs if the
+    not is in the statement )
+    bug only appears if the array is referred to using a pointer -
+      if using TBug, and no pointers it compiles fine
+      with PBug the error appears
+    }
+ 
+  Left^[test] := not Left^[test];
+end.
+

tests/tbs0184.pp

@@ -0,0 +1,25 @@
+Program Bug0184;
+
+{ multiple copies of the constant sets are stored in the assembler file when
+  they are needed more than once}
+
+Var BSet: Set of Byte;
+    SSet: Set of 0..31;
+    b,c: byte;
+    s: 0..31;
+
+Begin
+  BSet := BSet + [b];  {creates a big, empty set}
+  BSet := BSet + [c];  {creates another one}
+  BSet := BSet + [3];  {creates a big set with element three set}
+  BSet := BSet + [3];  {and antoher one}
+
+  SSet := SSet + [5];  {creates a small set containing 5}
+  SSet := SSet + [s];  {creates a small, empty set}
+  SSet := SSet + [5];  {creates another small set containing 5}
+  SSet := SSet + [s];  {creates another small, empty set}
+
+{BTW: small constant sets don't have to be stored seperately in the
+ executable, as they're simple 32 bit constants, like longints!}
+
+End.

tests/tbs0185.pp

@@ -0,0 +1,30 @@
+Program bug0185;
+
+{shows some bugs with rangechecks}
+
+var s: String;
+    i: integer;
+    code: word;
+    e: 0..10;
+
+Begin
+{$R-}
+  s := '$fffff';
+  val(s, i, code); {no range check error may occur here}
+  Writeln('Integer($fffff) = ',i);
+
+  Write('Enter the value 20 (should not give a rangecheck error): ');
+  Readln(e);
+{$R+}
+  s := '$ffff';
+  val(s, i, code); {no range check error may occur here}
+  Writeln('integer($ffff) = ', i,'(should not give range check error)');
+
+  Writeln('Enter value from 0-10 to test Val rangecheck, another for subrange rangecheck: ');
+  Readln(e);
+
+  Writeln('If you entered a value different from 0-10, subrange range checks don''t work!');
+  s := '65535';
+  val(s, i, code); {must give a range check error}
+  Writeln('Val range check failed!');
+End.

tests/tbs0187.pp

@@ -0,0 +1,66 @@
+program test;
+
+type
+        Tbaseclass = object
+                constructor     Init;
+                destructor      Done;
+                procedure       Run;                            virtual;
+
+        end;
+        Totherclass = object(Tbaseclass)
+                procedure       Run;                            virtual;
+
+        end;
+
+constructor Tbaseclass.Init;
+
+begin
+  writeln('Init');
+  Run;
+end;
+
+destructor Tbaseclass.Done;
+
+begin
+  writeln('Done');
+end;
+
+procedure Tbaseclass.Run;
+
+begin
+  writeln('Base method');
+end;
+
+
+procedure Totherclass.Run;
+
+begin
+  writeln('Inherited method');
+end;
+
+var     base            : Tbaseclass;
+        other           : Totherclass;
+//        asmrec          : Tasmrec;
+        testfield       : longint;
+
+begin
+// Uncommenting here and commenting the init in the WIth solves it.
+//  Base.Init;
+  with base do
+  begin
+    Init;
+    Run;
+    Done;
+  end;
+// Uncommenting here and commenting the init in the WIth solves it.
+//  Other.init;
+  with other do
+  begin
+    Init;
+    Run;
+    Done;
+  end;
+
+{ Calls Tbaseclass.Run when it should call Totherclass.Run }
+
+end.

tests/tbs0188.pp

@@ -0,0 +1,42 @@
+{ this are no bugs, just wrong 
+  understanding of FPC syntax }
+
+type testfunc = function:longint;
+
+var f : testfunc;
+
+var test: testfunc;
+
+function test_temp: longint;
+begin
+  test_temp:=12;
+end;
+
+procedure sound(test: testfunc);
+begin
+  {writeln(test); this is wrong because
+   test is the function itself and write does not know how to
+   output a function !
+   to call test you must use test() !! }
+  writeln(test()); 
+end; { proc. sound }
+
+var i : longint;
+begin
+  i:=test_temp;
+  f:=@test_temp;
+  if f()<>i then
+    begin
+       Writeln('error calling f');
+       Halt(1);
+    end;
+
+  { this works for FPC
+   sound(test_temp);
+  but the correct syntax would be }
+  sound(@test_temp);
+  { imagine if a function would return its own type !! }
+ 
+  { for f var this is correct also ! }
+  sound(f);
+end.

tests/tbs0189.pp

@@ -0,0 +1,22 @@
+var m: procedure;
+
+procedure test;
+begin
+end;
+
+procedure test2;
+begin
+end;
+
+begin
+ if @test <> @test2 then
+   writeln('different!')
+ else
+   writeln('error');
+ m:=@test;
+
+ { here also the syntax was wrong !! }
+ {  @m <> @test have different types !! }
+ if m <> @test then
+   writeln('error');
+end.

tests/tbs0190.pp

@@ -0,0 +1,10 @@
+procedure a(var b: boolean);
+begin
+  b:=true;
+end;
+
+var C: byte;
+
+begin
+  a(boolean(c));
+end.

tests/tbs0191.pp

@@ -0,0 +1,20 @@
+type
+  trec=record
+   a,b : longint;
+  end;
+  prec=^trec;
+
+const
+  s  : string = 'test';
+  pc : pchar = @s[1];
+
+  cfg : array[1..2] of trec=(
+   (a:1;b:2),
+   (a:3;b:4)
+  );
+  pcfg : prec = @cfg[2];
+
+  l : ^longint = @cfg[1].b; { l^ should be 2 }
+
+begin
+end.

tests/tbs0192.pp

@@ -0,0 +1,8 @@
+var
+  k,l : word;
+begin
+  if (k<>l)=false then
+   ;
+  if (k<>l)=true then
+   ;
+end.

tests/tbs0193.pp

@@ -0,0 +1,14 @@
+{$Q+}
+var i: integer;
+    b: byte;
+
+begin
+  i := 32767;
+  i := i + 15;
+  b := 255;
+  b := b + 18;
+  b := 255;
+  b := b * 8;
+  b := 255;
+  b := b * 17
+End.

tests/tbs0194.pp

@@ -0,0 +1,42 @@
+{$Q+}
+
+type
+   tproc = function : longint;
+
+var
+   f : tproc;
+   fa : array [0..1] of tproc;
+
+   function dummy : longint;
+     begin
+        dummy:=25;
+     end;
+const
+   prog_has_errors : boolean = false;
+
+   procedure Wrong(const s : string);
+     begin
+        writeln(s);
+        prog_has_errors:=True;
+     end;
+
+Begin
+   f:=@dummy;
+   if f()<>25 then
+     Wrong('f() does not call dummy !!');
+   if pointer(@f)=pointer(@dummy) then
+     Wrong('@f returns value of f !');
+   if longint(f)=longint(@f) then
+     Wrong('longint(@f)=longint(f) !!!!');
+   if f<>@dummy then 
+     Wrong('f does not return the address of dummy');
+   if longint(@f)=longint(@dummy) then
+     Wrong('longint(@f) returns address of dummy instead of address of f');
+   fa[0]:=@dummy;
+   if longint(@f)=longint(@fa[0]) then
+     Wrong('arrays of procvar also wrong');
+   if longint(f)<>longint(fa[0]) then
+     Wrong('arrays of procvar and procvars are handled differently !!'); 
+   if prog_has_errors then
+     Halt(1);
+End.

tests/tbs0195.pp

@@ -0,0 +1,30 @@
+uses graph
+{$ifdef go32v2}
+,dpmiexcp
+{$endif go32v2};
+var
+   GDriver, GMode: Integer;
+   w:word;
+   p:pointer;
+begin
+   GDriver := $FF;
+   GMode := $101;
+   InitGraph(GDriver, GMode, '');
+   if (GraphResult <> grOK) then
+     Halt(0);
+   rectangle(0,0,getmaxx,getmaxy);
+   w := imagesize(0,0,111,111);
+   getmem(p, w);
+
+   {---runtime-error!------}
+   { getimage(0,0,111,111, p); }
+   {-----------------------}
+   
+   { This is the correct usage (PFV) }
+   getimage(0,0,111,111, p^);
+   
+
+   freemem(p, w);
+   closegraph;
+   readln;
+end.

tests/tbs0198.pp

@@ -0,0 +1,9 @@
+type
+   to1 = class
+       function GetCaps1 : Longint;virtual;abstract;
+       function GetCaps2 : Longint;virtual;stdcall;
+       function GetCaps : Longint;virtual;stdcall;abstract;
+   end;
+
+begin
+end.