Index: frontend-passes.c =================================================================== --- frontend-passes.c (Revision 186213) +++ frontend-passes.c (Arbeitskopie) @@ -796,20 +796,45 @@ optimize_op (gfc_expr *e) { gfc_intrinsic_op op = e->value.op.op; + /* Only use new-style comparisions. */ + switch(op) + { + case INTRINSIC_EQ_OS: + op = INTRINSIC_EQ; + break; + + case INTRINSIC_GE_OS: + op = INTRINSIC_GE; + break; + + case INTRINSIC_LE_OS: + op = INTRINSIC_LE; + break; + + case INTRINSIC_NE_OS: + op = INTRINSIC_NE; + break; + + case INTRINSIC_GT_OS: + op = INTRINSIC_GT; + break; + + case INTRINSIC_LT_OS: + op = INTRINSIC_LT; + break; + + default: + break; + } + switch (op) { case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: case INTRINSIC_GE: - case INTRINSIC_GE_OS: case INTRINSIC_LE: - case INTRINSIC_LE_OS: case INTRINSIC_NE: - case INTRINSIC_NE_OS: case INTRINSIC_GT: - case INTRINSIC_GT_OS: case INTRINSIC_LT: - case INTRINSIC_LT_OS: return optimize_comparison (e, op); default: @@ -819,6 +844,61 @@ optimize_op (gfc_expr *e) return false; } +/* Return true if a constant string contains spaces only. */ + +static bool +empty_string (gfc_expr *e) +{ + int i; + + if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) + return false; + + for (i=0; ivalue.character.length; i++) + { + if (e->value.character.string[i] != ' ') + return false; + } + + return true; +} + +/* Insert a call to the intrinsic len_trim. Use a different name for + the symbol tree so we don't run into trouble when the user has + renamed len_trim for some reason. */ + +static gfc_expr* +get_len_trim_call (gfc_expr *str, int kind) +{ + gfc_expr *fcn; + gfc_actual_arglist *actual_arglist, *next; + + fcn = gfc_get_expr (); + fcn->expr_type = EXPR_FUNCTION; + fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); + actual_arglist = gfc_get_actual_arglist (); + actual_arglist->expr = str; + next = gfc_get_actual_arglist (); + next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind); + actual_arglist->next = next; + + fcn->value.function.actual = actual_arglist; + fcn->where = str->where; + fcn->ts.type = BT_INTEGER; + fcn->ts.kind = gfc_charlen_int_kind; + + gfc_get_sym_tree("__internal_len_trim", current_ns, &fcn->symtree, false); + fcn->symtree->n.sym->ts = fcn->ts; + fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; + fcn->symtree->n.sym->attr.function = 1; + fcn->symtree->n.sym->attr.elemental = 1; + fcn->symtree->n.sym->attr.referenced = 1; + fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; + gfc_commit_symbol (fcn->symtree->n.sym); + + return fcn; +} + /* Optimize expressions for equality. */ static bool @@ -862,6 +942,46 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op if (e->rank > 0) return change; + /* Replace a == '' with len_trim(a) == 0 and a /= '' with + len_trim(a) != 0 */ + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && (op == INTRINSIC_EQ || op == INTRINSIC_NE)) + { + + bool empty_op1, empty_op2; + empty_op1 = empty_string(op1); + empty_op2 = empty_string(op2); + + if (empty_op1 || empty_op2) + { + gfc_expr *fcn; + gfc_expr *zero; + gfc_expr *str; + + /* This can only happen when an error for comparing + characters of different kinds has already been issued. */ + if (empty_op1 && empty_op2) + return false; + + zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0); + str = empty_op1 ? op2 : op1; + + fcn = get_len_trim_call (str, gfc_charlen_int_kind); + + + if (empty_op1) + gfc_free_expr (op1); + else + gfc_free_expr (op2); + + op1 = fcn; + op2 = zero; + e->value.op.op1 = fcn; + e->value.op.op2 = zero; + } + } + + /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */ if (flag_finite_math_only @@ -935,32 +1055,26 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op switch (op) { case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: result = eq == 0; break; case INTRINSIC_GE: - case INTRINSIC_GE_OS: result = eq >= 0; break; case INTRINSIC_LE: - case INTRINSIC_LE_OS: result = eq <= 0; break; case INTRINSIC_NE: - case INTRINSIC_NE_OS: result = eq != 0; break; case INTRINSIC_GT: - case INTRINSIC_GT_OS: result = eq > 0; break; case INTRINSIC_LT: - case INTRINSIC_LT_OS: result = eq < 0; break; @@ -992,7 +1106,6 @@ optimize_trim (gfc_expr *e) gfc_expr *a; gfc_ref *ref; gfc_expr *fcn; - gfc_actual_arglist *actual_arglist, *next; gfc_ref **rr = NULL; /* Don't do this optimization within an argument list, because @@ -1041,17 +1154,7 @@ optimize_trim (gfc_expr *e) /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */ - fcn = gfc_get_expr (); - fcn->expr_type = EXPR_FUNCTION; - fcn->value.function.isym = - gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); - actual_arglist = gfc_get_actual_arglist (); - actual_arglist->expr = gfc_copy_expr (e); - next = gfc_get_actual_arglist (); - next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, - gfc_default_integer_kind); - actual_arglist->next = next; - fcn->value.function.actual = actual_arglist; + fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind); /* Set the end of the reference to the call to len_trim. */