+ several bugs converted

tests/README

@@ -27,11 +27,7 @@ ts010015.pp       tests typed files.
 ts010016.pp       tests conversion of smallsets in normsets in consts 
 ts010017.pp       tests the problem of iocheck inside iocheck routines
 ts010018.pp       tests the problem of enums inside objects
-ts010019.pp	  tests problems of name mangling
-ts010020.pp	  tests for const strings problems if const is a single char.
-ts010021.pp	  test for long mangled names (they are strings, ie no longer then
-		  255 chars (but they have to be allways shorten the same way !!)
-ts010022.pp       tests a problem of writing pchar in files
+
 ts10100.pp        tests for delphi object model
 -
 ts101xx.pp

tests/readme.txt

@@ -4,7 +4,7 @@
   with compilation and execution tests.
 
   Standard way :
-  'make tests' will try to compile all the sources
+  'make all' will try to compile all the sources
    will printout a list of errors
   - programs that do not compile but should
   - programs that do compile when they should create an error !

tests/tbf0049.pp

@@ -0,0 +1,11 @@
+type
+   days = (Mon,Tue,Wed,Thu,Fri,Sat,Sun);
+   weekend = Sat..Sun;
+
+var
+   w : weekend;
+
+begin
+   w:=5;
+   {$message the line before should produce an error }
+end.

tests/tbf0071.pp

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

tests/tbf0075.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/tbf0155.pp

@@ -0,0 +1,17 @@
+{ this is not a real bug but rather a feature :
+  assembler function are only accepted for 
+  simple return values
+  i.e. either in register or FPU  (PM) }
+
+{ so for the moment this is rejected code ! }
+
+function asmstr:string;assembler;
+asm
+	movl	__RESULT,%edi
+	movl	$0x4101,%al
+	stosw
+end;
+
+begin
+  writeln(asmstr);
+end;

tests/tbf0161.pp

@@ -0,0 +1,11 @@
+Program tbs0161;
+
+{the following program should give a syntax error, but causes an internal error}
+
+const s = [1,2,3,4,5];
+
+var b: Byte;
+
+Begin
+  If b in [s] then;
+End.

tests/tbs0177.pp

@@ -0,0 +1,6 @@
+program p;
+var
+  l : longint;
+begin
+  p.l:=1;
+end.  

tests/tbs0178.pp

@@ -0,0 +1,64 @@
+PROGRAM NoLabel; { this program compiles fine with TP but not with FP }
+
+ type
+    ptestobj = ^ttestobj;
+    ttestobj = object
+            constructor init;
+            procedure test_self;
+            end;
+
+ const
+    allowed : boolean = false;
+    
+    constructor ttestobj.init;
+      begin
+        if not allowed then
+          fail;
+      end;
+    procedure ttestobj.test_self;
+      function myself : ptestobj;
+        begin
+           myself:=@self;
+        end;
+
+      begin
+         if myself<>@self then
+           begin
+              Writeln('problem with self');
+              Halt(1);
+           end;
+      end;
+         
+
+LABEL
+  N1,
+  N2,
+  FAIL, { this is a reserved word in constructors only! - FP fails here
+}
+  More; { label not defined - FP fails, but a warning is enough for that
+}
+           { since label referenced nowhere }
+ var ptest : ptestobj;
+     self : longint;
+BEGIN
+  new(ptest,init);
+  if ptest<>nil then
+    begin
+       Writeln('Fail does not work !!');
+       Halt(1);
+    end;
+  allowed:=true;
+  new(ptest,init);
+  if ptest=nil then
+    begin
+       Writeln('Constructor does not work !!');
+       Halt(1);
+    end
+  else
+    ptest^.test_self;
+  N1: Write;
+  N2: Write;
+  FAIL: Write;
+  self:=1;
+END.
+

tests/tbs0179.pp

@@ -0,0 +1,10 @@
+{ $OPT= -So }
+UNIT tbs0179;
+INTERFACE
+  PROCEDURE A(B:WORD);
+IMPLEMENTATION
+  PROCEDURE A;  { <-- works with TP, FP says overloading problem }
+  BEGIN
+    Write(B);
+  END;
+END.

tests/tbs0180.pp

@@ -0,0 +1,15 @@
+{ $OPT=-Un }
+{ this name should be accepted with -Un option !! }
+UNIT bug0180;
+INTERFACE
+  uses 
+     tbs0180a;
+
+  procedure dummy;
+IMPLEMENTATION
+  procedure dummy;
+    begin
+      { Unit_with_strange_name.dummy; should this work ?? }
+      tbs0180a.dummy; 
+    end;
+END.

tests/tbs0180a.pp

@@ -0,0 +1,13 @@
+{ $OPT=-Un }
+{ this name should be accepted with -Un option !! }
+UNIT Unit_with_strange_name;
+INTERFACE
+  procedure dummy;
+IMPLEMENTATION
+  procedure dummy;
+    begin
+    end;
+
+begin
+   Unit_with_strange_name.dummy;
+END.

tests/tbs0181.pp

@@ -0,0 +1,9 @@
+{ shows a problem of name mangling  }
+Program bug0181;
+
+  Uses tbs0181a;
+
+  var l : mylongint;
+begin
+  dummy(l);
+end.

tests/tbs0181a.pp

@@ -0,0 +1,27 @@
+{ shows a problem of name mangling  }
+Unit tbs0181a;
+
+Interface
+
+  type mylongint = longint;
+       mylongint2 = mylongint;
+
+  procedure dummy(var l : mylongint);
+
+Implementation
+
+  var l : longint;
+
+  procedure use_before_implemented;
+    begin
+       dummy(l);
+    end;
+
+  procedure dummy(var l : mylongint2);
+    begin
+       l:=78;
+    end;
+
+begin
+   use_before_implemented;
+end.

tests/tesirand.pp

@@ -1,3 +1,17 @@
+{
+  $Id$
+
+  This program test the random function
+  It gets 10M random values
+  that are placed in 10000 windows
+  and print the number of occurence for each window
+  and the profile of the distribution
+  of the counts
+
+  - this gave very bad value due to a modulo problem
+    but after this solved
+    it still shows strange wings !!
+}
 program test_random;
 
 uses
@@ -8,34 +22,49 @@ uses
    
 
 const max = 1000;
-      maxint = 1000*max;
+      maxint = 10000*max;
       
 
 var x : array[0..max-1] of longint;
-    mean,level,i,maximum,minimum : longint;
+    y : array[-100..100] of longint;
+    
+    mean,level,i : longint;
+    maxcount,delta,maximum,minimum : longint;
     st,st2 : string;
-    gm,gd : word;
+    gm,gd : integer;
     color : longint;
     
 begin
 
+{$ifdef FPC}
    gm:=G640x400x256;
    gd:=$ff;
-   InitGraph(gd,gm,'');
+{$else }
+   gd:=detect;
+{$endif }
+   InitGraph(gd,gm,'\bp\bgi');
+{$ifdef FPC}
    SetWriteMode(NormalPut or BackPut);
+{$endif FPC}
    SetColor(red);
    color:=blue;
 
    mean:=maxint div max;
    
-   for level:=1 to 10 do
+   for level:=0 to 10 do
      begin
+     
         for i:=0 to max-1 do
           x[i]:=0;
+        for i:=-100 to 100 do
+          y[i]:=0;
         for i:=0 to maxint-1 do
           begin
-             inc(x[random(max*level*100) div (level*100)]);
-             if i mod 1000 = 0 then
+             if level=0 then
+               inc(x[trunc(random*max)])
+             else
+               inc(x[random(max*level) div (level)]);
+             if i mod (maxint div 10) = 0 then
                begin
                   st:='';
                   str(i,st);
@@ -46,16 +75,25 @@ begin
           end;
         maximum:=0;
         minimum:=$7FFFFFFF;
+        maxcount:=0;
         for i:=0 to max-1 do
           begin
              if x[i]>maximum then
                maximum:=x[i];
              if x[i]<minimum then
                minimum:=x[i];
+             if abs(x[i]-mean)<100 then
+               inc(y[x[i]-mean]);
           end;
         if maximum=0 then
           inc(maximum);
-     
+
+        for i:=-100 to 100 do
+          if y[i]>maxcount then
+            maxcount:=y[i];
+        if maxcount=0 then
+          inc(maxcount);
+          
         OutTextXY(GetMaxX div 2,GetMaxY-30,'Random Test Program');
         
         str(level,st);
@@ -66,13 +104,34 @@ begin
         st:='Maximum = '+st+' Minimum ='+st2;
         OutTextXY(30,GetMaxY-30,st);
         
-        
         for i:=0 to max-1 do
-          putpixel( (i*getmaxX) div max, GetMaxY-(x[i]*getMaxY) div (2*mean), color);
+          putpixel( (i*getmaxX) div max,
+            GetMaxY-(x[i]*getMaxY) div (2*mean), color);
+        inc(color);
+        setColor(color);
+        delta:=maximum-minimum+1;
+        for i:=-100 to 100 do
+          begin
+            if i=minimum then
+              moveto( ((i+100)*getMaxX) div 201,
+                GetMaxY-(y[i]*getMaxY) div maxcount)
+            else
+              lineto( ((i+100)*getMaxX) div 201,
+                GetMaxY-(y[i]*getMaxY) div maxcount);
+            if y[i]>0 then
+              circle( ((i+100)*getMaxX) div 201,
+                GetMaxY-(y[i]*getMaxY) div maxcount,5);
+          end;
         readln;
         inc(color);
      end;
    CloseGraph;
 end.
         
+{
+  $Log$
+  Revision 1.2  1998-11-23 23:44:52  pierre
+   + several bugs converted
+
+}