Implement simplification of ordinal case nodes if the case expression is constant (might be useful when inlining).

+ nset.pas, tcasenode: add simplify method; for ordinal constant case expressions either return a copy of the correct block or return a nothing node if the constant did not match anything

+ added test to check that nothing is broken

git-svn-id: trunk@26824 -

.gitattributes

@@ -10160,6 +10160,7 @@ tests/tbs/tb0600.pp svneol=native#text/plain
 tests/tbs/tb0601.pp svneol=native#text/pascal
 tests/tbs/tb0602.pp svneol=native#text/plain
 tests/tbs/tb0603.pp svneol=native#text/pascal
+tests/tbs/tb0604.pp svneol=native#text/pascal
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/tbs0594.pp svneol=native#text/pascal
 tests/tbs/ub0060.pp svneol=native#text/plain

compiler/nset.pas

@@ -102,6 +102,7 @@ interface
           procedure insertintolist(l : tnodelist);override;
           function pass_typecheck:tnode;override;
           function pass_1 : tnode;override;
+          function simplify(forinline:boolean):tnode;override;
           function docompare(p: tnode): boolean; override;
           procedure addlabel(blockid:longint;l,h : TConstExprInt); overload;
           procedure addlabel(blockid:longint;l,h : tstringconstnode); overload;
@@ -840,6 +841,41 @@ implementation
       end;
 
 
+    function tcasenode.simplify(forinline:boolean):tnode;
+      var
+        tmp: pcaselabel;
+      begin
+        result:=nil;
+        if left.nodetype=ordconstn then
+          begin
+            tmp:=labels;
+            { walk the case labels as long as the upper bound is smaller than
+              the constant }
+            while assigned(tmp) and (tmp^._high<tordconstnode(left).value) do
+              tmp:=tmp^.greater;
+            { check whether the constant is inside the range }
+            if assigned(tmp) and
+                (tmp^._low<=tordconstnode(left).value) and
+                (tmp^._high>=tordconstnode(left).value) then
+              begin
+                if tmp^.blockid>=blocks.count then
+                  internalerror(2014022101);
+                result:=pcaseblock(blocks[tmp^.blockid])^.statement;
+                if not assigned(result) then
+                  internalerror(2014022102);
+                result:=result.getcopy;
+                exit;
+              end;
+            { no label did match; use the else block if available }
+            if assigned(elseblock) then
+              result:=elseblock.getcopy
+            else
+              { no else block, so there is no code to execute at all }
+              result:=cnothingnode.create;
+          end;
+      end;
+
+
     function tcasenode.dogetcopy : tnode;
       var
          n : tcasenode;

tests/tbs/tb0604.pp

@@ -0,0 +1,169 @@
+program tb0604;
+
+{$mode objfpc}
+
+{.$define writeresults}
+
+procedure CheckResult(aActual, aExpected, aExitCode: LongInt);
+begin
+  if aActual <> aExpected then begin
+{$ifdef writeresults}
+    Writeln('Test ', aExitCode, ' failed. Result: ', aActual, ' Expected: ', aExpected);
+{$endif}
+    Halt(aExitCode);
+  end;
+end;
+
+function TestSimple1: LongInt;
+begin
+  case 4 of
+    2: Result := 2;
+    4: Result := 4;
+    6: Result := 6;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestSimple2: LongInt;
+begin
+  case 8 of
+    2: Result := 2;
+    4: Result := 4;
+    6: Result := 6;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestSimple3: LongInt;
+begin
+  case 1 of
+    2: Result := 2;
+    4: Result := 4;
+    6: Result := 6;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestSimple4: LongInt;
+begin
+  case 3 of
+    2: Result := 2;
+    4: Result := 4;
+    6: Result := 6;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestSimple5: LongInt;
+begin
+  case 3 of
+    2: Result := 2;
+    4: Result := 4;
+    6: Result := 6;
+  end;
+  Result := 8;
+end;
+
+function TestRange1: LongInt;
+begin
+  case 4 of
+    2..4: Result := 3;
+    6..8: Result := 7;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestRange2: LongInt;
+begin
+  case 3 of
+    2..4: Result := 3;
+    6..8: Result := 7;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestRange3: LongInt;
+begin
+  case 2 of
+    2..4: Result := 3;
+    6..8: Result := 7;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestRange4: LongInt;
+begin
+  case 5 of
+    2..4: Result := 3;
+    6..8: Result := 7;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestRange5: LongInt;
+begin
+  case 9 of
+    2..4: Result := 3;
+    6..8: Result := 7;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestRange6: LongInt;
+begin
+  case 1 of
+    2..4: Result := 3;
+    6..8: Result := 7;
+    else
+      Result := 8;
+  end;
+end;
+
+function TestInlineFunc(a, b: LongInt): LongInt; inline;
+begin
+  case a of
+    0..4:
+      Result := a * b;
+    6..9:
+      Result := a + b;
+  end;
+
+  case b of
+    0..4:
+      Result := Result - (a - b);
+    6..9:
+      Result := Result * (a mod b);
+  end;
+end;
+
+function TestInline: LongInt;
+begin
+  Result := TestInlineFunc(7, 3);
+end;
+
+begin
+  CheckResult(TestSimple1, 4, 1);
+  CheckResult(TestSimple2, 8, 2);
+  CheckResult(TestSimple3, 8, 3);
+  CheckResult(TestSimple4, 8, 4);
+  CheckResult(TestSimple5, 8, 5);
+  CheckResult(TestRange1, 3, 6);
+  CheckResult(TestRange2, 3, 7);
+  CheckResult(TestRange3, 3, 8);
+  CheckResult(TestRange4, 8, 9);
+  CheckResult(TestRange5, 8, 10);
+  CheckResult(TestRange6, 8, 11);
+  CheckResult(TestInline, 6, 121);
+{$ifdef writeresults}
+  Writeln('ok');
+{$endif}
+end.