bugs 230-241

tests/erroru.pp

@@ -32,6 +32,7 @@ end;
 procedure require_error(num : longint);
 begin
    required_error_num:=num;
+   accepted_error_num:=num;
 end;
 
 procedure error_unit_exit;
@@ -42,14 +43,14 @@ begin
         if (required_error_num<>0) and (exitcode<>required_error_num) then
           begin
              Write('Program ',paramstr(0));
-             Write('exited with error ',exitcode,' whereas error ');
+             Write(' exited with error ',exitcode,' whereas error ');
              Writeln(required_error_num,' was expected');
              Halt(1);
           end
         else if exitcode<>accepted_error_num then
           begin
              Write('Program ',paramstr(0));
-             Write('exited with error ',exitcode,' whereas only error ');
+             Write(' exited with error ',exitcode,' whereas only error ');
              Writeln(accepted_error_num,' was expected');
              Halt(1);
           end;
@@ -57,12 +58,17 @@ begin
    else if required_error_num<>0 then
      begin
         Write('Program ',paramstr(0));
-        Write('exited without error whereas error ');
+        Write(' exited without error whereas error ');
         Writeln(required_error_num,' was expected');
         Halt(1);
      end;
    if program_has_error then
-     Halt(1);
+     Halt(1)
+   else
+     begin
+        exitcode:=0;
+        erroraddr:=nil;
+     end;
 end;
 
 begin

tests/tbf0230.pp

@@ -0,0 +1,14 @@
+{$ifdef go32v2}
+uses
+   dpmiexcp;
+{$endif}
+
+var
+   e : extended;
+
+begin
+ e:=-1.0;
+ writeln(ln(e));
+ writeln(ln(0));
+ writeln(power(0,1.0));
+end .

tests/tbf0234.pp

@@ -0,0 +1,8 @@
+program bug0232;
+
+var p:pointer;
+
+begin
+     new(p);
+     dispose(p);
+end.

tests/tbf0242.pp

@@ -0,0 +1,11 @@
+procedure p;
+begin
+end;
+
+procedure p1(var x);
+begin
+end;
+
+begin
+  p1(p);
+end.

tests/tbs0229.pp

@@ -0,0 +1,34 @@
+{$mode objfpc}
+{$X-}
+
+const
+   CRLF = #13#10;
+   c =
+        '1-----------------'+CRLF+
+        '2/PcbDict 200 dict'+CRLF+
+        '3PcbDicljkljkljk b'+CRLF+
+        '4PcbDict /DictMaix'+CRLF+
+        '5% draw a pin-poll'+CRLF+
+        '6% get x+CRLF+ y s'+CRLF+
+        '7/thickness exch h'+CRLF+
+        '8gsave x y transls'+CRLF+
+        '9---------jljkljkl'+crlf+
+        '10----------2jkljk'+crlf+
+        '11----------jkllkk'+crlf+
+        'eeeeeeeeeeeeeeeeee'+crlf+
+        '2-----------------'+CRLF+
+        '2/PcbDict 200 dice'+CRLF+
+        'END____.XXXXXxjk b'+CRLF+
+        '4PcbDict /DictMaix'+CRLF+
+        '5% draw a pin-poll'+CRLF+
+        '6% get x+CRLF+ y s'+CRLF+
+        '7/thickness exch h'+CRLF+
+        '8gsave x y transls'+CRLF+
+        '9---------jljkljkl'+crlf+
+        '10----------2jkljk'+crlf+
+        '11----------jkllkk'+crlf+
+        'eeeeeeeeeeeeeeeeee12';
+
+begin
+   write(c);
+end.

tests/tbs0231.pp

@@ -0,0 +1,17 @@
+
+{$undef dummy}
+
+{$ifdef DUMMY}
+   (* <= this should not be considered as a 
+   higher comment level !!
+   
+  test
+{$endif dummy}
+
+var
+   e : extended;
+
+begin
+ e:=1.0;
+ writeln(ln(e));
+end.

tests/tbs0232.pp

@@ -0,0 +1,8 @@
+const
+   p : procedure a;stdcall=nil;   { <----- this doesn't what you expect !!!!}
+   p : procedure a stdcall=nil;   { so delphi supports also this way of }
+                                  { declaration                         }
+
+begin
+end.
+

tests/tbs0233.pp

@@ -0,0 +1,31 @@
+program except_test;
+
+type byteset = set of byte;
+     enumset = set of (zero,one,two,three);
+     
+function test(s : byteset) : boolean;
+begin
+  test:=false;
+  if 0 in s then
+    begin
+       Writeln('Contains zero !');
+       test:=true;
+    end;
+end;
+
+function testenum(s : enumset) : boolean;
+begin
+  testenum:=false;
+
+  if zero in s then
+    begin
+       Writeln('Contains zero !');
+       testenum:=true;
+    end;
+end;
+
+begin
+  if test([1..5,8]) then halt(1);
+  if not test([0,8,15]) then halt(1);
+  if not testenum([zero,two]) then halt(1);
+end.

tests/tbs0235.pp

@@ -0,0 +1,17 @@
+program bug0233;
+
+var s:string;
+    w:cardinal;
+    code:word;
+
+begin
+    s:='192';
+    val(s,w,code);
+    if code<>0 then
+        begin
+           writeln('Error');
+           halt(1);
+        end
+    else
+        writeln(w);
+end.

tests/tbs0236.pp

@@ -0,0 +1,40 @@
+{$R+}
+program test_set_subrange;
+
+uses
+  erroru;
+
+ type
+   enum = (zero,one,two,three);
+
+   sub_enum = one..three;
+   prec = ^trec;
+   
+   trec = record
+     dummy : longint;
+     en : enum;
+     next : prec;
+   end;
+
+ const
+   str : array[sub_enum] of string = ('one','two','three');
+
+procedure test;
+
+ var hp : prec;
+    t : sub_enum;
+ 
+ begin
+   new(hp);
+   hp^.en:=zero;
+   new(hp^.next);
+   hp^.next^.en:=three;
+   t:=hp^.en;
+   Writeln('hp^.en = ',str[hp^.en]);
+   Writeln('hp^.next^.en = ',str[hp^.next^.en]);
+ end;
+
+begin
+  require_error(201);
+  test;
+end.

tests/tbs0237.pp

@@ -0,0 +1,22 @@
+unit tbs0237;
+interface
+
+  procedure sub1(w1,w2:word);
+
+implementation
+
+procedure p1;
+
+  procedure sub1(w:word);
+  begin
+  end;
+
+begin
+end;
+
+
+procedure sub1(w1,w2:word);
+begin
+end;
+
+end.

tests/tbs0238.pp

@@ -0,0 +1,35 @@
+program test1;
+
+           {compiles under TPC - PPC386 gives internal error}
+
+Type str1=string[160];
+
+var
+   fileof  :file of str1;
+   lol   :array[1..8] of str1;
+   nu,n:integer;
+   i,tt    :str1;
+   ul   :text;
+   a: str1;
+
+
+procedure test;
+
+
+begin
+   for nu:=1 to 8 do read(fileof,lol[nu]);
+   writeln('File contents');
+   for nu:=4 to 8 do writeln(lol[nu]);
+end;
+
+
+begin
+  assign(fileof,'test.dat');
+  rewrite(fileof);
+  a:='dummy string !!';
+  for nu:=1 to 8 do write(fileof,a);
+  close(fileof);
+  reset(fileof);
+  test;
+  close(fileof);
+end.

tests/tbs0239.pp

@@ -0,0 +1,14 @@
+{$mode delphi}
+   uses sysutils;
+   type
+     ttest=class
+     end;
+     ttestclass=class of ttest;
+   var
+     i:ttest;
+     tt:tclass;
+   begin
+     tt:=ttest;
+     write(i is tt);
+   end.
+

tests/tbs0240.pp

@@ -0,0 +1,21 @@
+Program TEST;
+
+var CurFileCrc32f : cardinal{Longint};
+    CheckThis : String;
+
+BEGIN
+  CurFileCrc32f := $C5CAF43C;
+  CheckThis := '';
+  Case CurFileCrc32f of
+    $F3DC2AF0 :  CheckThis := ' First ';
+    $27BF798B :  CheckThis := ' Second ';
+    $7BA5BB19 :  CheckThis := ' Third';
+    $FA246A81 :  CheckThis := ' Forth';
+    $8A00B508 :  CheckThis := ' Fifth';
+    $C5CAF43C :  CheckThis := ' Sixth';
+  End;
+  Writeln( CheckThis );
+  If CheckThis<>' Sixth' then halt(1);
+END.
+
+

tests/tbs0241.pp

@@ -0,0 +1,14 @@
+{$OPT= -Twin32}
+
+program test_win32_drv;
+
+procedure printer;external 'winspool.drv' name 'AbortPrinter';
+procedure test;
+
+ begin
+   Writeln('Loading of Winspool works ');
+ end;
+
+begin
+  test;
+end.