new tbs and tbf added, some rewritten

tests/tbf0203.pp

@@ -0,0 +1,13 @@
+program tbf0203;
+
+uses 
+{$ifdef go32v2}
+  dpmiexcp,
+{$endif def go32v2}
+  tbf0203a;
+
+begin
+   c;
+   a;
+end.
+

tests/tbf0203a.pp

@@ -0,0 +1,25 @@
+unit tbf0203a;
+
+interface
+   procedure a;
+   procedure c;
+
+   const is_called : boolean = false;
+
+implementation
+
+   procedure c;
+     begin
+        a;
+     end;
+
+   procedure b;[public, alias : '_assembler_a'];
+     begin
+        Writeln('b called'); 
+        Is_called:=true;
+     end;
+
+   procedure a;external name '_assembler_a';
+
+end.
+

tests/tbf0205.pp

@@ -0,0 +1,31 @@
+program bug_show;
+{ By PAV (pavsoft@usa.net) }
+
+function bad_uppercase(s:string):string;
+var i:integer;
+begin
+  for i:=1 to length(s) do
+    if (ord(s[i])>=97 and ord(s[i])<=122) then s[i]:=chr(ord(s[i])-97+65);
+  bad_uppercase:=s;
+end;
+
+function good_uppercase(s:string):string;
+var i:integer;
+begin
+  for i:=1 to length(s) do
+    if (ord(s[i])>=97) and (ord(s[i])<=122) then s[i]:=chr(ord(s[i])-97+65);
+  good_uppercase:=s;
+end;
+
+const cadena='Free Paskal Compiler 0.99.8  !!! (bug)';
+begin
+  writeln('This is the original string before convert it');
+  writeln(cadena);
+  writeln();
+  writeln('This is a bad result, using "if (  and  )"');
+  writeln(bad_uppercase(cadena));
+  writeln();
+  writeln('This is a good result, using "if () and ()"');
+  writeln(good_uppercase(cadena));
+  writeln();
+end.

tests/tbf0208.pp

@@ -0,0 +1,11 @@
+program tbf0208;
+
+{ implicit boolean to integer conversion should not be
+  allowed }
+var
+  b : boolean;
+  i : longint;
+begin
+  b:=true;
+  i:=b;
+end.

tests/tbs0037.pp

@@ -8,10 +8,11 @@ begin
    gd:=detect;
    initgraph(gd,gm,'');
    line(1,1,100,100);
-   readkey;
+   {readkey;}
    setgraphmode($107);
    line(100,100,1024,800);
-   readkey;
+   {readkey;}
+   delay(1000);
    closegraph;
 end.
    

tests/tbs0048.pp

@@ -11,7 +11,7 @@ begin
    initgraph(gd,gm,'');
    setcolor(brown);
    line(0,0,getmaxx,0);
-   readkey;
+   {readkey;}delay(1000);
    size:=imagesize(0,0,getmaxx,0);
    getmem(p,size);
    getimage(0,0,getmaxx,0,p^);
@@ -20,12 +20,12 @@ begin
      begin
         putimage(0,i,p^,xorput);
      end;
-   readkey;
+   {readkey;}delay(1000);
    for i:=0 to getmaxy do
      begin
         putimage(0,i,p^,xorput);
      end;
-   readkey;
+   {readkey;}delay(1000);
    closegraph;
 end.
    

tests/tbs0051.pp

@@ -38,7 +38,7 @@ BEGIN
   for i:=0 to 255 do
    if not ColorsEqual(getpixel(i,15),getpixel(i,30)) then
      Halt(1); 
-  readkey;
+  {readkey;}delay(1000);
 
   closegraph;
 END.

tests/tbs0052.pp

@@ -1,5 +1,5 @@
 uses 
-  graph;
+  crt,graph;
 
 const
   Triangle: array[1..3] of PointType = ((X: 50; Y: 100), (X: 100; Y:100),
@@ -16,10 +16,10 @@ begin
   if GraphResult <> grOk then
     Halt(1);
   drawpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle);
-  readln;
+  {readln;}delay(1000);
   setcolor(red);
   fillpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle);
-  readln;
+  {readln;}delay(1000);
   SetFillStyle(SolidFill,blue);
   Bar(0,0,GetMaxX,GetMaxY);
   Rectangle(25,25,GetMaxX-25,GetMaxY-25);
@@ -30,6 +30,6 @@ begin
   fillpoly(SizeOf(Rect) div SizeOf(PointType), Rect);
   fillpoly(SizeOf(Penta) div SizeOf(PointType), Penta);
   graphdefaults;
-  readln;
+  {readln;}delay(1000);
   CloseGraph;
 end.

tests/tbs0057.pp

@@ -9,10 +9,10 @@ begin
    gm:=$103;
    initgraph(gd,gm,'');
    line(1,1,100,100);
-   readkey;
+   {readkey;}delay(1000);
    closegraph;
    initgraph(gd,gm,'');
    line(100,100,1,100);
-   readkey;
+   {readkey;}delay(1000);
    closegraph;
 end.

tests/tbs0102.pp

@@ -1,10 +1,11 @@
-{ $OPT= -Tamiga }
+{ assembler reader of m68k for register ranges }
 
 unit tbs0102;
   interface
 
   implementation
 
+{$ifdef M68K}
     procedure int_help_constructor;
 
       begin
@@ -12,6 +13,7 @@ unit tbs0102;
             movem.l d0-a7,-(sp)
          end;
       end;
+{$endif M68K}
 
 
   end.

tests/tbs0123.pp

@@ -1,3 +1,4 @@
+{ bug for shrd assemblerreader }
 begin
 {$asmmode intel}
    asm

tests/tbs0124.pp

@@ -1,11 +1,41 @@
+
+{ this problem comes from the fact that 
+  L is a static variable, not a local one !!
+  but the static variable symtable is the localst of the
+  main procedure (PM) 
+  It must be checked if we are at main level or not !! }
+
 var
  l : longint;
+
+  procedure error;
+    begin
+       Writeln('Error in tbs0124');
+       Halt(1);
+    end;
+
 begin
+{$asmmode direct}
+  asm
+    movl $5,l
+  end;
+  if l<>5 then error;
+{$asmmode att}
+ asm
+   movl  l,%eax
+   addl  $2,%eax
+   movl  %eax,l
+ end; 
+  if l<>7 then error;
 {$asmmode intel}
  { 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]
+   mov eax,l
+   add eax,5
+   mov l,eax
  end;
+ if l<>12 then error; 
+ Writeln('tbs0124 OK'); 
 end.

tests/tbs0128.pp

@@ -1,3 +1,6 @@
+{ ^ followed by a letter must be interpreted differently
+  depending on context }
+
 const
    ArrowKeysOrFirstLetter='arrow keys '^]^r^z' or First letter.   ';
 

tests/tbs0141.pp

@@ -23,15 +23,15 @@ var
 
 begin
 a := TObjectAB.Create;
-WriteLn(a.InstanceSize, '  Should be: 8');
+WriteLn(a.InstanceSize, '  Should be: 12');
-if a.InstanceSize + SizeOf(integer)*2 <> SizeOf(TObjectABCD) then
+if a.InstanceSize + SizeOf(integer)*2 <> TObjectABCD.InstanceSize then
   Halt(1);
 b := TObjectABCD.Create;
-if b.InstanceSize + SizeOf(integer)*2 <> SizeOf(TObjectABCDEF) then
+if b.InstanceSize + SizeOf(integer)*2 <> TObjectABCDEF.InstanceSize then
   Halt(1);
-WriteLn(b.InstanceSize, '  Should be: 16');
+WriteLn(b.InstanceSize, '  Should be: 20');
 c := TObjectABCDEF.Create;
-WriteLn(c.InstanceSize, '  Should be: 24');
+WriteLn(c.InstanceSize, '  Should be: 28');
 end.
 
 {

tests/tbs0202.pp

@@ -0,0 +1,31 @@
+program silly;
+
+var greater : boolean;
+
+procedure error;
+begin
+   Writeln('Error in tbs0202');
+   Halt(1);
+end;
+
+procedure compare(i,j : integer);
+begin
+   case (i>j) of
+     true : begin
+                greater:=true;
+            end;
+     false : begin
+                greater:=false;
+             end;
+   end;
+end;
+
+begin
+  compare(45,2);
+  if not greater then
+    error;
+  compare(-5,26)
+  if greater then 
+    error; 
+end.
+

tests/tbs0204.pp

@@ -0,0 +1,30 @@
+{ boolean(byte) byte(boolean)
+  word(wordbool) wordbool(word)
+  longint(longbool) and longbool(longint)
+  must be accepted as var parameters
+  or a left of an assignment }
+
+procedure error;
+begin
+   Writeln('Error in tbs0204');
+   Halt(1);
+end;
+
+var
+  b : boolean;
+  wb : wordbool;
+  lb : longbool;
+
+begin
+  byte(b):=1;
+  word(wb):=1;
+  longint(lb):=1;
+  if (not b) or (not wb) or (not lb) then
+    error;
+  byte(b):=2;
+  Writeln('if a boolean contains 2 it is considered as ',b);
+  byte(b):=3;
+  Writeln('if a boolean contains 3 it is considered as ',b);
+  shortint(b):=-1;
+  Writeln('if a boolean contains shortint(-1) it is considered as ',b);
+end.

tests/tbs0206.pp

@@ -0,0 +1,10 @@
+PROGRAM SetRange_Bug;
+CONST a:char='A';z:char='Z';
+VAR s:set of char;c:char;
+BEGIN
+ s:=[a..z];
+ for c:=#0 to #255 do
+  if c in s then
+   write(c);
+ writeln;
+END.

tests/tbs0207.pp

@@ -0,0 +1,8 @@
+
+{$mode delphi}
+ var i : longint;
+
+begin
+   for i:=1 to maxlongint do 
+     tobject.create.free;
+end.

tests/tbs0209.pp

@@ -0,0 +1,18 @@
+program bug0209;
+
+{ problem with boolean expression mixing different boolean sizes }
+
+var
+  b : boolean;
+  wb : wordbool;
+  lb : longbool;
+begin
+  b:=true;
+  wb:=true;
+  lb:=true;
+  if (not b) or (not wb) or (not lb) then
+    begin
+       Writeln('Error with boolean expressions of different sizes');
+       Halt(1);
+    end;
+end.