فهرست منبع

Added two new overflow tests

J. Gareth "Curious Kit" Moreton 3 سال پیش
والد
کامیت
29ea731b2f
3فایلهای تغییر یافته به همراه185 افزوده شده و 0 حذف شده
  1. 181 0
      tests/test/cg/toverflow.inc
  2. 2 0
      tests/test/cg/toverflow1a.pp
  3. 2 0
      tests/test/cg/toverflow1b.pp

+ 181 - 0
tests/test/cg/toverflow.inc

@@ -0,0 +1,181 @@
+{*******************************************************************}
+{ Tests overflow checks when PostPeepholeOptADDSUB has taken effect }
+{ when adding or subtracting 128 to a variable                      }
+{*******************************************************************}
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+program toverflow;
+uses
+  SysUtils;
+  
+  function TestOverflow32(Initial: LongWord; Subtract, OverflowExpected: Boolean): Boolean;
+    var
+      Output: LongWord;
+    begin
+	  Result := False;
+      if Subtract then
+        Write('Testing 32-bit subtraction of 128 from ', Initial, '... ')
+      else
+        Write('Testing 32-bit addition of 128 to ', Initial, '... ');
+    
+      try
+        if Subtract then
+          Output := Initial - $80
+        else
+          Output := Initial + $80;
+      
+		Write('no exception... ');
+        
+		if OverflowExpected then
+          begin
+            WriteLn('FAIL: Overflow not triggered then it should have');
+            Exit(True);
+          end
+		else if Subtract then
+		  begin
+            if Output + $80 <> Initial then
+              begin
+                WriteLn('FAIL: Result of ', Output, ' was incorrect');
+                Exit(True);
+              end;
+		  end
+		else
+		  begin
+            if Output - $80 <> Initial then
+              begin
+                WriteLn('FAIL: Result of ', Output, ' was incorrect');
+                Exit(True);
+              end;
+		  end
+          
+      except
+        on E: ERangeError do
+          if not OverflowExpected then 
+            begin
+              WriteLn('FAIL: Range error triggered when it shouldn''t have');
+              Exit(True);
+            end
+		  else
+		    Write('ERangeError triggered... ');
+
+        on E: EIntOverflow do
+          if not OverflowExpected then 
+            begin
+              WriteLn('FAIL: Overflow triggered when it shouldn''t have');
+              Exit(True);
+            end
+		  else
+		    Write('EIntOverflow triggered... ');
+
+        on E: Exception do
+          begin
+            WriteLn('FAIL: Unexpected exception ' + E.ClassName + ': ' + E.Message);
+            Exit(True);
+          end;
+      end;
+      
+      WriteLn('Pass');
+    end;
+  
+  function TestOverflow64(Initial: QWord; Subtract, OverflowExpected: Boolean): Boolean;
+    var
+      Output: QWord;
+    begin
+	  Result := False;
+      if Subtract then
+        Write('Testing 64-bit subtraction of 128 from ', Initial, '... ')
+      else
+        Write('Testing 64-bit addition of 128 to ', Initial, '... ');
+    
+      try
+        if Subtract then
+          Output := Initial - $80
+        else
+          Output := Initial + $80;
+		  
+		Write('no exception... ');
+      
+        if OverflowExpected then
+          begin
+            WriteLn('FAIL: Overflow not triggered then it should have');
+            Exit(True);
+          end
+		else if Subtract then
+		  begin
+            if Output + $80 <> Initial then
+              begin
+                WriteLn('FAIL: Result of ', Output, ' was incorrect');
+                Exit(True);
+              end;
+		  end
+		else
+		  begin
+            if Output - $80 <> Initial then
+              begin
+                WriteLn('FAIL: Result of ', Output, ' was incorrect');
+                Exit(True);
+              end;
+		  end
+          
+      except
+        on E: ERangeError do
+          if not OverflowExpected then 
+            begin
+              WriteLn('FAIL: Range error triggered when it shouldn''t have');
+              Exit(True);
+            end
+		  else
+		    Write('ERangeError triggered... ');
+
+        on E: EIntOverflow do
+          if not OverflowExpected then 
+            begin
+              WriteLn('FAIL: Overflow triggered when it shouldn''t have');
+              Exit(True);
+            end
+		  else
+		    Write('EIntOverflow triggered... ');
+
+        on E: Exception do
+          begin
+            WriteLn('FAIL: Unexpected exception ' + E.ClassName + ': ' + E.Message);
+            Exit(True);
+          end;
+      end;
+      
+      WriteLn('Pass');
+    end;
+
+var
+  Fail: Boolean = False;
+begin
+  { 32-bit add }
+  Fail := TestOverflow32($FFFFFF7F, False, False) or Fail;
+  Fail := TestOverflow32($FFFFFF80, False, True) or Fail; { Result is zero and overflows }
+  Fail := TestOverflow32($FFFFFF81, False, True) or Fail;
+  Fail := TestOverflow32($FFFFFFFF, False, True) or Fail;
+  
+  { 32-bit subtract }
+  Fail := TestOverflow32($81, True, False) or Fail;
+  Fail := TestOverflow32($80, True, False) or Fail; { Result is zero but doesn't overflow }
+  Fail := TestOverflow32($7F, True, True) or Fail;
+  Fail := TestOverflow32($0, True, True) or Fail;  
+
+  { 64-bit add }
+  Fail := TestOverflow64(QWord($FFFFFFFFFFFFFF7F), False, False) or Fail;
+  Fail := TestOverflow64(QWord($FFFFFFFFFFFFFF80), False, True) or Fail; { Result is zero and overflows }
+  Fail := TestOverflow64(QWord($FFFFFFFFFFFFFF81), False, True) or Fail;
+  Fail := TestOverflow64(QWord($FFFFFFFFFFFFFFFF), False, True) or Fail;
+  
+  { 64-bit subtract }
+  Fail := TestOverflow64($81, True, False) or Fail;
+  Fail := TestOverflow64($80, True, False) or Fail; { Result is zero but doesn't overflow }
+  Fail := TestOverflow64($7F, True, True) or Fail;
+  Fail := TestOverflow64($0, True, True) or Fail;  
+  
+  ExitCode := LongInt(Fail);
+  if not Fail then
+    WriteLn('ok');
+end.

+ 2 - 0
tests/test/cg/toverflow1a.pp

@@ -0,0 +1,2 @@
+{ %OPT=-O2 -OoNOPEEPHOLE -Cro }
+{$I toverflow.inc}

+ 2 - 0
tests/test/cg/toverflow1b.pp

@@ -0,0 +1,2 @@
+{ %OPT=-O2 -Cro }
+{$I toverflow.inc}