*** empty log message ***

tests/test/dotest.pp

@@ -0,0 +1,20 @@
+unit dotest;
+
+  interface
+{$ifdef go32v2}
+    uses
+       dpmiexcp;
+{$endif go32v2}
+
+    procedure do_error(l : longint);
+
+  implementation
+
+    procedure do_error(l : longint);
+
+      begin
+         writeln('Error near: ',l);
+         halt(100);
+      end;
+
+end.

tests/test/readme.txt

@@ -0,0 +1,7 @@
+This directory contains tests for several parts of the compiler:
+The tests ordered how they should be executed
+
+Ansistrings .................. testansi.pp
+Classes ...................... testdom.pp
+Exceptions ................... testexc.pp
+                               testexc2.pp

tests/test/testexc2.pp

@@ -0,0 +1,28 @@
+{$mode objfpc}
+uses
+   dotest,
+   sysutils;
+
+procedure d;
+
+  var
+     d1 : double;
+
+  begin
+     d1:=0;
+     d1:=1/d1;
+  end;
+
+var
+   i : longint;
+
+begin
+   d;
+   for i:=1 to 20 do
+     try
+        d;
+     except
+       on exception do
+         ;
+     end;
+end.

tests/test/testexc3.pp

@@ -0,0 +1,338 @@
+uses
+   dotest;
+
+var
+   i : longint;
+
+procedure test1;
+
+  begin
+     try
+        i:=0;
+        exit;
+     finally
+        inc(i);
+     end;
+     i:=-2;
+  end;
+
+procedure test2;
+
+  begin
+     try
+        i:=0;
+        raise exception.create('');
+     finally
+        inc(i);
+     end;
+     i:=-2;
+  end;
+
+procedure test3;
+
+  begin
+     try
+       try
+          i:=0;
+          raise exception.create('');
+       finally
+          inc(i);
+       end;
+     finally
+       inc(i);
+     end;
+     i:=-2;
+  end;
+
+procedure test4;
+
+  begin
+     try
+       try
+          i:=0;
+          exit;
+       finally
+          inc(i);
+       end;
+     finally
+       inc(i);
+     end;
+     i:=-2;
+  end;
+
+procedure test5;
+
+  var
+     j : longint;
+
+  begin
+     for l:=1 to 10 do
+       begin
+          try
+             i:=0;
+             break;
+          finally
+            inc(i);
+          end;
+          dec(i);
+       end;
+  end;
+
+procedure test6;
+
+  var
+     j : longint;
+
+  begin
+     i:=0;
+     for l:=1 to 10 do
+       try
+          continue;
+        finally
+          inc(i);
+        end;
+        dec(i);
+     end;
+  end;
+
+procedure test7;
+
+  var
+     j : longint;
+
+  begin
+     for j:=1 to 10 do
+       begin
+          try
+            try
+               i:=0;
+               break;
+             finally
+               inc(i);
+             end;
+             dec(i);
+          finally
+            inc(i);
+          end;
+       end;
+  end;
+
+procedure test8;
+
+  var
+     j : longint;
+
+  begin
+     i:=0;
+     for j:=1 to 10 do
+       begin
+          try
+             try
+                continue;
+             finally
+                inc(i);
+             end;
+          finally
+             inc(i);
+          end;
+          dec(i);
+       end;
+  end;
+
+
+{ some combined test ... }
+
+procedure test9;
+
+  var
+     j : longint;
+
+  begin
+     try
+        i:=0;
+     finally
+        for j:=1 to 10 do
+           begin
+              try
+                 if j<2 then
+                   continue
+                 else
+                   break;
+              finally
+                 inc(i);
+              end;
+              dec(i);
+           end;
+     end;
+  end;
+
+procedure test10;
+
+  var
+     j : longint;
+
+  begin
+     try
+        i:=0;
+        j:=1;
+     finally
+       while j<=10 do
+         begin
+            try
+               if j<2 then
+                 continue
+               else
+                 break;
+            finally
+               inc(i);
+               inc(j);
+            end;
+            dec(i);
+         end;
+     end;
+  end;
+
+{ the do_raise function is a little bit more complicated }
+{ so we also check if memory is lost                     }
+function do_raise : ansistring;
+
+  var
+     a1,a2 : ansistring;
+
+  begin
+     for i:=1 to 3 do
+       begin
+          a1:=copy('Hello world',1,5);
+          do_raise:=copy(a2,1,1);
+       end;
+     raise exception.create('A string to test memory allocation');
+     do_error(99998);
+  end;
+
+
+{ now test real exceptions }
+procedure test100;
+
+  begin
+     try
+        i:=0;
+        do_raise;
+     except
+        inc(i);
+     end;
+  end;
+
+procedure test101;
+
+  begin
+     try
+        try
+           i:=0;
+           do_raise;
+        except
+           inc(i);
+           do_raise;
+        end;
+     except
+        inc(i);
+     end;
+  end;
+
+procedure test102;
+
+  begin
+     try
+        try
+           i:=0;
+           do_raise;
+        except
+           inc(i);
+           reraise;
+        end;
+     except
+        inc(i);
+     end;
+  end;
+
+var
+   startmemvail : longint;
+
+begin
+   startmemavail:=memavail;
+   i:=-1;
+   try
+     test1;
+   except
+     inc(i);
+   end;
+   if i<>2 then
+     do_error(1001);
+
+   i:=-1;
+   test2;
+   if i<>1 then
+     do_error(1002);
+
+   i:=-1;
+   try
+      test3;
+   except
+      inc(i);
+   end;
+   if i<>3 then
+     do_error(1003);
+
+   i:=-1;
+   test4;
+   if i<>2 then
+     do_error(1004);
+
+   i:=-1;
+   test5;
+   if i<>1 then
+     do_error(1005);
+
+   i:=-1;
+   test6;
+   if i<>10 then
+     do_error(1006);
+
+   i:=-1;
+   test7;
+   if i<>2 then
+     do_error(1007);
+
+   i:=-1;
+   test8;
+   if i<>20 then
+     do_error(1008);
+
+   i:=-1;
+   test9;
+   if i<>2 then
+     do_error(1009);
+
+   i:=-1;
+   test10;
+   if i<>2 then
+     do_error(1010);
+
+   i:=-1;
+   test100;
+   if i<>1 then
+     do_error(1100);
+
+   i:=-1;
+   test101;
+   if i<>2 then
+     do_error(1101);
+
+   i:=-1;
+   test102;
+   if i<>2 then
+     do_error(1102);
+
+   if memavail<>startmemvail then
+     do_error(99999);
+   halt(0);
+end.