From 500920030be1fdd816f414487e1e7e4f65d9516e Mon Sep 17 00:00:00 2001 From: svenbarth Date: Fri, 21 Feb 2014 20:36:41 +0000 Subject: [PATCH] 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 | 1 + compiler/nset.pas | 36 ++++++++++ tests/tbs/tb0604.pp | 169 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 206 insertions(+) create mode 100644 tests/tbs/tb0604.pp diff --git a/.gitattributes b/.gitattributes index 325bc6dd7b..650c9abdb0 100644 --- a/.gitattributes +++ b/.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 diff --git a/compiler/nset.pas b/compiler/nset.pas index 96f2e727f3..23582e866c 100644 --- a/compiler/nset.pas +++ b/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) 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; diff --git a/tests/tbs/tb0604.pp b/tests/tbs/tb0604.pp new file mode 100644 index 0000000000..e6f2aa1b78 --- /dev/null +++ b/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.