Hi Tobias,
here is an updated version of the patch, with a more extensive test
case. Also regression-tested.
OK for trunk?
Thomas
2012-01-31 Thomas König <tkoe...@gcc.gnu.org>
PR fortran/51958
* frontend-passes.c (convert_elseif): New function.
(optimize_namespace): Call it.
2012-01-31 Thomas König <tkoe...@gcc.gnu.org>
PR fortran/51958
* gfortran.dg/function_optimize_10.f90: New test.
! { do-do run }
! PR 51958 - this used to generate wrong code.
! Original test case by Don Simons.
program main
implicit none
logical :: test1_ok
logical :: test2_ok
logical :: test3_ok
character(len=1):: charq
charq = 'c'
test1_ok = .true.
test2_ok = .false.
if (charq .eq. ' ') then
test1_ok = .false.
else if ((my_ichar(charq).ge.97 .and. my_ichar(charq).le.103)) then
test2_OK = .true.
end if
if ((.not. test1_ok) .or. (.not. test2_ok)) call abort
test1_ok = .true.
test2_ok = .true.
test3_ok = .false.
if (charq .eq. ' ') then
test1_ok = .false.
else if ((my_ichar(charq).lt.97 .or. my_ichar(charq).gt.103)) then
test2_ok = .false.
else if ((my_ichar(charq).ge.97 .and. my_ichar(charq).le.103)) then
test3_ok = .true.
end if
if ((.not. test1_ok) .or. (.not. test2_ok) .or. (.not. test3_ok)) call abort
test1_ok = .true.
test2_ok = .true.
test3_ok = .false.
if (charq .eq. ' ') then
test1_ok = .false.
else if ((my_ichar(charq).lt.97 .or. my_ichar(charq).gt.103)) then
test2_ok = .false.
else
test3_ok = .true.
end if
if ((.not. test1_ok) .or. (.not. test2_ok) .or. (.not. test3_ok)) call abort
contains
pure function my_ichar(c)
integer :: my_ichar
character(len=1), intent(in) :: c
my_ichar = ichar(c)
end function my_ichar
end program main
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (Revision 183449)
+++ frontend-passes.c (Arbeitskopie)
@@ -509,6 +509,70 @@ convert_do_while (gfc_code **c, int *walk_subtrees
return 0;
}
+/* Code callback function for converting
+ if (a) then
+ ...
+ else if (b) then
+ end if
+
+ into
+ if (a) then
+ else
+ if (b) then
+ end if
+ end if
+
+ because otherwise common function elimination would place the BLOCKs
+ into the wrong place. */
+
+static int
+convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_code *c_if1, *c_if2, *else_stmt;
+
+ if (co->op != EXEC_IF)
+ return 0;
+
+ /* This loop starts out with the first ELSE statement. */
+ else_stmt = co->block->block;
+
+ while (else_stmt != NULL)
+ {
+ gfc_code *next_else;
+
+ /* If there is no condition, we're done. */
+ if (else_stmt->expr1 == NULL)
+ break;
+
+ next_else = else_stmt->block;
+
+ /* Generate the new IF statement. */
+ c_if2 = XCNEW (gfc_code);
+ c_if2->op = EXEC_IF;
+ c_if2->expr1 = else_stmt->expr1;
+ c_if2->next = else_stmt->next;
+ c_if2->loc = else_stmt->loc;
+ c_if2->block = next_else;
+
+ /* ... plus the one to chain it to. */
+ c_if1 = XCNEW (gfc_code);
+ c_if1->op = EXEC_IF;
+ c_if1->block = c_if2;
+ c_if1->loc = else_stmt->loc;
+
+ /* Insert the new IF after the ELSE. */
+ else_stmt->expr1 = NULL;
+ else_stmt->next = c_if1;
+ else_stmt->block = NULL;
+ else_stmt->next = c_if1;
+
+ else_stmt = next_else;
+ }
+ /* Don't walk subtrees. */
+ return 0;
+}
/* Optimize a namespace, including all contained namespaces. */
static void
@@ -520,6 +584,7 @@ optimize_namespace (gfc_namespace *ns)
in_omp_workshare = false;
gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
+ gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
