diff options
Diffstat (limited to 'gcc/fortran/expr.cc')
| -rw-r--r-- | gcc/fortran/expr.cc | 293 |
1 files changed, 285 insertions, 8 deletions
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 0753667..a11ff79 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -116,6 +116,25 @@ gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, return e; } +/* Get a new expression node that is an conditional expression node. */ + +gfc_expr * +gfc_get_conditional_expr (locus *where, gfc_expr *condition, + gfc_expr *true_expr, gfc_expr *false_expr) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_CONDITIONAL; + e->value.conditional.condition = condition; + e->value.conditional.true_expr = true_expr; + e->value.conditional.false_expr = false_expr; + + if (where) + e->where = *where; + + return e; +} /* Get a new expression node that is an structure constructor of given type and kind. */ @@ -393,6 +412,15 @@ gfc_copy_expr (gfc_expr *p) break; + case EXPR_CONDITIONAL: + q->value.conditional.condition + = gfc_copy_expr (p->value.conditional.condition); + q->value.conditional.true_expr + = gfc_copy_expr (p->value.conditional.true_expr); + q->value.conditional.false_expr + = gfc_copy_expr (p->value.conditional.false_expr); + break; + case EXPR_FUNCTION: q->value.function.actual = gfc_copy_actual_arglist (p->value.function.actual); @@ -502,6 +530,12 @@ free_expr0 (gfc_expr *e) gfc_free_expr (e->value.op.op2); break; + case EXPR_CONDITIONAL: + gfc_free_expr (e->value.conditional.condition); + gfc_free_expr (e->value.conditional.true_expr); + gfc_free_expr (e->value.conditional.false_expr); + break; + case EXPR_FUNCTION: gfc_free_actual_arglist (e->value.function.actual); break; @@ -1083,6 +1117,11 @@ gfc_is_constant_expr (gfc_expr *e) && (e->value.op.op2 == NULL || gfc_is_constant_expr (e->value.op.op2))); + case EXPR_CONDITIONAL: + return gfc_is_constant_expr (e->value.conditional.condition) + && gfc_is_constant_expr (e->value.conditional.true_expr) + && gfc_is_constant_expr (e->value.conditional.false_expr); + case EXPR_VARIABLE: /* The only context in which this can occur is in a parameterized derived type declaration, so returning true is OK. */ @@ -1194,6 +1233,7 @@ is_subref_array (gfc_expr * e) what follows cannot be a subreference array, unless there is a substring reference. */ if (!seen_array && ref->type == REF_COMPONENT + && ref->next == NULL && ref->u.c.component->ts.type != BT_CHARACTER && ref->u.c.component->ts.type != BT_CLASS && !gfc_bt_struct (ref->u.c.component->ts.type)) @@ -1353,6 +1393,43 @@ simplify_intrinsic_op (gfc_expr *p, int type) return true; } +/* Try to collapse conditional expressions. */ + +static bool +simplify_conditional (gfc_expr *p, int type) +{ + gfc_expr *condition, *true_expr, *false_expr; + + condition = p->value.conditional.condition; + true_expr = p->value.conditional.true_expr; + false_expr = p->value.conditional.false_expr; + + if (!gfc_simplify_expr (condition, type) + || !gfc_simplify_expr (true_expr, type) + || !gfc_simplify_expr (false_expr, type)) + return false; + + if (!gfc_is_constant_expr (condition)) + return true; + + p->value.conditional.condition = NULL; + p->value.conditional.true_expr = NULL; + p->value.conditional.false_expr = NULL; + + if (condition->value.logical) + { + gfc_replace_expr (p, true_expr); + gfc_free_expr (false_expr); + } + else + { + gfc_replace_expr (p, false_expr); + gfc_free_expr (true_expr); + } + gfc_free_expr (condition); + + return true; +} /* Subroutine to simplify constructor expressions. Mutually recursive with gfc_simplify_expr(). */ @@ -1371,7 +1448,7 @@ simplify_constructor (gfc_constructor_base base, int type) || !gfc_simplify_expr (c->iterator->step, type))) return false; - if (c->expr) + if (c->expr && c->expr->expr_type != EXPR_CONSTANT) { /* Try and simplify a copy. Replace the original if successful but keep going through the constructor at all costs. Not @@ -1837,6 +1914,55 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) } +/* Simplify inquiry references (%re/%im) of constant complex arrays. + Used by find_inquiry_ref. */ + +static gfc_expr * +simplify_complex_array_inquiry_ref (gfc_expr *p, inquiry_type inquiry) +{ + gfc_expr *e, *r, *result; + gfc_constructor_base base; + gfc_constructor *c; + + if ((inquiry != INQUIRY_RE && inquiry != INQUIRY_IM) + || p->expr_type != EXPR_ARRAY + || p->ts.type != BT_COMPLEX + || p->rank <= 0 + || p->value.constructor == NULL + || !gfc_is_constant_array_expr (p)) + return NULL; + + /* Simplify array sections. */ + gfc_simplify_expr (p, 0); + + result = gfc_get_array_expr (BT_REAL, p->ts.kind, &p->where); + result->rank = p->rank; + result->shape = gfc_copy_shape (p->shape, p->rank); + + base = p->value.constructor; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + e = c->expr; + if (e->expr_type != EXPR_CONSTANT) + goto fail; + + r = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + if (inquiry == INQUIRY_RE) + mpfr_set (r->value.real, mpc_realref (e->value.complex), GFC_RND_MODE); + else + mpfr_set (r->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); + + gfc_constructor_append_expr (&result->value.constructor, r, &e->where); + } + + return result; + +fail: + gfc_free_expr (result); + return NULL; +} + + /* Pull an inquiry result out of an expression. */ static bool @@ -1845,7 +1971,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) gfc_ref *ref; gfc_ref *inquiry = NULL; gfc_ref *inquiry_head; + gfc_ref *ref_ss = NULL; gfc_expr *tmp; + bool nofail = false; tmp = gfc_copy_expr (p); @@ -1861,6 +1989,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) { inquiry = ref->next; ref->next = NULL; + if (ref->type == REF_SUBSTRING) + ref_ss = ref; + break; } } @@ -1890,6 +2021,28 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) goto cleanup; + /* Inquire length of substring? */ + if (ref_ss) + { + if (ref_ss->u.ss.start->expr_type == EXPR_CONSTANT + && ref_ss->u.ss.end->expr_type == EXPR_CONSTANT) + { + HOST_WIDE_INT istart, iend, length; + istart = gfc_mpz_get_hwi (ref_ss->u.ss.start->value.integer); + iend = gfc_mpz_get_hwi (ref_ss->u.ss.end->value.integer); + + if (istart <= iend) + length = iend - istart + 1; + else + length = 0; + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, length); + break; + } + else + goto cleanup; + } + if (tmp->ts.u.cl->length && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) *newp = gfc_copy_expr (tmp->ts.u.cl->length); @@ -1920,24 +2073,50 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) break; case INQUIRY_RE: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + if (tmp->ts.type != BT_COMPLEX) goto cleanup; if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) goto cleanup; + if (tmp->expr_type == EXPR_ARRAY) + { + *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_RE); + if (*newp != NULL) + { + nofail = true; + break; + } + } + + if (tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); mpfr_set ((*newp)->value.real, mpc_realref (tmp->value.complex), GFC_RND_MODE); break; case INQUIRY_IM: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + if (tmp->ts.type != BT_COMPLEX) goto cleanup; if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) goto cleanup; + if (tmp->expr_type == EXPR_ARRAY) + { + *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_IM); + if (*newp != NULL) + { + nofail = true; + break; + } + } + + if (tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); mpfr_set ((*newp)->value.real, mpc_imagref (tmp->value.complex), GFC_RND_MODE); @@ -1950,7 +2129,7 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) if (!(*newp)) goto cleanup; - else if ((*newp)->expr_type != EXPR_CONSTANT) + else if ((*newp)->expr_type != EXPR_CONSTANT && !nofail) { gfc_free_expr (*newp); goto cleanup; @@ -2356,6 +2535,11 @@ gfc_simplify_expr (gfc_expr *p, int type) return false; break; + case EXPR_CONDITIONAL: + if (!simplify_conditional (p, type)) + return false; + break; + case EXPR_VARIABLE: /* Only substitute array parameter variables if we are in an initialization expression, or we want a subsection. */ @@ -2366,7 +2550,8 @@ gfc_simplify_expr (gfc_expr *p, int type) { if (!simplify_parameter_variable (p, type)) return false; - break; + if (!iter_stack) + break; } if (type == 1) @@ -2522,7 +2707,7 @@ scalarize_intrinsic_call (gfc_expr *e, bool init_flag) rank[n] = a->expr->rank; else rank[n] = 1; - ctor = gfc_constructor_copy (a->expr->value.constructor); + ctor = a->expr->value.constructor; args[n] = gfc_constructor_first (ctor); } else @@ -3029,6 +3214,20 @@ gfc_check_init_expr (gfc_expr *e) break; + case EXPR_CONDITIONAL: + t = gfc_check_init_expr (e->value.conditional.condition); + if (!t) + break; + t = gfc_check_init_expr (e->value.conditional.true_expr); + if (!t) + break; + t = gfc_check_init_expr (e->value.conditional.false_expr); + if (t) + t = gfc_simplify_expr (e, 0); + else + t = false; + break; + case EXPR_FUNCTION: t = false; @@ -3505,6 +3704,20 @@ check_restricted (gfc_expr *e) break; + case EXPR_CONDITIONAL: + t = check_restricted (e->value.conditional.condition); + if (!t) + break; + t = check_restricted (e->value.conditional.true_expr); + if (!t) + break; + t = check_restricted (e->value.conditional.false_expr); + if (t) + t = gfc_simplify_expr (e, 0); + else + t = false; + break; + case EXPR_FUNCTION: if (e->value.function.esym) { @@ -3836,7 +4049,13 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, if (has_pointer && (ref == NULL || ref->next == NULL) && lvalue->symtree->n.sym->attr.data) return true; - else + /* Prevent the following error message for caf-single mode, because there + are no teams in single mode and the simplify returns a null then. */ + else if (!(flag_coarray == GFC_FCOARRAY_SINGLE + && rvalue->ts.type == BT_DERIVED + && rvalue->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && rvalue->ts.u.derived->intmod_sym_id + == ISOFORTRAN_TEAM_TYPE)) { gfc_error ("NULL appears on right-hand side in assignment at %L", &rvalue->where); @@ -4659,6 +4878,52 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) memset (&lvalue, '\0', sizeof (gfc_expr)); + if (sym && sym->attr.pdt_template && comp && comp->initializer) + { + int i, flag; + gfc_expr *param_expr; + flag = 0; + + if (comp->as && comp->as->type == AS_EXPLICIT + && !(comp->ts.type == BT_DERIVED + && comp->ts.u.derived->attr.pdt_template)) + { + /* Are the bounds of the array parameterized? */ + for (i = 0; i < comp->as->rank; i++) + { + param_expr = gfc_copy_expr (comp->as->lower[i]); + if (gfc_simplify_expr (param_expr, 1) + && param_expr->expr_type != EXPR_CONSTANT) + flag++; + gfc_free_expr (param_expr); + param_expr = gfc_copy_expr (comp->as->upper[i]); + if (gfc_simplify_expr (param_expr, 1) + && param_expr->expr_type != EXPR_CONSTANT) + flag++; + gfc_free_expr (param_expr); + } + } + + /* Is the character length parameterized? */ + if (comp->ts.type == BT_CHARACTER && comp->ts.u.cl->length) + { + param_expr = gfc_copy_expr (comp->ts.u.cl->length); + if (gfc_simplify_expr (param_expr, 1) + && param_expr->expr_type != EXPR_CONSTANT) + flag++; + gfc_free_expr (param_expr); + } + + if (flag) + { + gfc_error ("The component %qs at %L of derived type %qs has " + "paramterized type or array length parameters, which is " + "not compatible with a default initializer", + comp->name, &comp->initializer->where, sym->name); + return false; + } + } + lvalue.expr_type = EXPR_VARIABLE; lvalue.ts = sym->ts; if (sym->as) @@ -5544,6 +5809,15 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, return true; break; + case EXPR_CONDITIONAL: + if (gfc_traverse_expr (expr->value.conditional.condition, sym, func, f)) + return true; + if (gfc_traverse_expr (expr->value.conditional.true_expr, sym, func, f)) + return true; + if (gfc_traverse_expr (expr->value.conditional.false_expr, sym, func, f)) + return true; + break; + default: gcc_unreachable (); break; @@ -5801,6 +6075,7 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) gfc_component *c; bool seen_assumed = false; bool seen_deferred = false; + bool seen_len = false; if (derived == NULL) { @@ -5822,10 +6097,12 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) return SPEC_EXPLICIT; seen_assumed = param_list->spec_type == SPEC_ASSUMED; seen_deferred = param_list->spec_type == SPEC_DEFERRED; + if (c->attr.pdt_len) + seen_len = true; if (seen_assumed && seen_deferred) return SPEC_EXPLICIT; } - res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; + res = (seen_assumed || !seen_len) ? SPEC_ASSUMED : SPEC_DEFERRED; } return res; } |