diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 147 |
1 files changed, 143 insertions, 4 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index de2da63..5ba4c8e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -588,9 +588,18 @@ resolve_structure_cons (gfc_expr * expr) /* If we don't have the right type, try to convert it. */ - if (!gfc_compare_types (&cons->expr->ts, &comp->ts) - && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE) - t = FAILURE; + if (!gfc_compare_types (&cons->expr->ts, &comp->ts)) + { + t = FAILURE; + if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN) + gfc_error ("The element in the derived type constructor at %L, " + "for pointer component '%s', is %s but should be %s", + &cons->expr->where, comp->name, + gfc_basic_typename (cons->expr->ts.type), + gfc_basic_typename (comp->ts.type)); + else + t = gfc_convert_type (cons->expr, &comp->ts, 1); + } } return t; @@ -686,6 +695,68 @@ procedure_kind (gfc_symbol * sym) return PTYPE_UNKNOWN; } +/* Check references to assumed size arrays. The flag need_full_assumed_size + is zero when matching actual arguments. */ + +static int need_full_assumed_size = 1; + +static int +check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e) +{ + gfc_ref * ref; + int dim; + int last = 1; + + if (!need_full_assumed_size + || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) + return 0; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + for (dim = 0; dim < ref->u.ar.as->rank; dim++) + last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT); + + if (last) + { + gfc_error ("The upper bound in the last dimension must " + "appear in the reference to the assumed size " + "array '%s' at %L.", sym->name, &e->where); + return 1; + } + return 0; +} + + +/* Look for bad assumed size array references in argument expressions + of elemental and array valued intrinsic procedures. Since this is + called from procedure resolution functions, it only recurses at + operators. */ +static bool +resolve_assumed_size_actual (gfc_expr *e) +{ + if (e == NULL) + return false; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + if (e->symtree + && check_assumed_size_reference (e->symtree->n.sym, e)) + return true; + break; + + case EXPR_OP: + if (resolve_assumed_size_actual (e->value.op.op1) + || resolve_assumed_size_actual (e->value.op.op2)) + return true; + break; + + default: + break; + } + return false; +} + /* Resolve an actual argument list. Most of the time, this is just resolving the expressions in the list. @@ -1083,9 +1154,16 @@ resolve_function (gfc_expr * expr) const char *name; try t; + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size = 0; + if (resolve_actual_arglist (expr->value.function.actual) == FAILURE) return FAILURE; + /* Resume assumed_size checking. */ + need_full_assumed_size = 1; + /* See if function is already resolved. */ if (expr->value.function.name != NULL) @@ -1129,7 +1207,6 @@ resolve_function (gfc_expr * expr) || (expr->value.function.isym != NULL && expr->value.function.isym->elemental))) { - /* The rank of an elemental is the rank of its array argument(s). */ for (arg = expr->value.function.actual; arg; arg = arg->next) @@ -1140,6 +1217,31 @@ resolve_function (gfc_expr * expr) break; } } + + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return FAILURE; + } + } + + else if (expr->value.function.actual != NULL + && expr->value.function.isym != NULL + && strcmp (expr->value.function.isym->name, "lbound")) + { + /* Array instrinsics must also have the last upper bound of an + asumed size array argument. */ + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return FAILURE; + } } if (!pure_function (expr, &name)) @@ -1381,9 +1483,17 @@ resolve_call (gfc_code * c) { try t; + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size = 0; + if (resolve_actual_arglist (c->ext.actual) == FAILURE) return FAILURE; + /* Resume assumed_size checking. */ + need_full_assumed_size = 1; + + t = SUCCESS; if (c->resolved_sym == NULL) switch (procedure_kind (c->symtree->n.sym)) @@ -1404,6 +1514,21 @@ resolve_call (gfc_code * c) gfc_internal_error ("resolve_subroutine(): bad function type"); } + if (c->ext.actual != NULL + && c->symtree->n.sym->attr.elemental) + { + gfc_actual_arglist * a; + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + for (a = c->ext.actual; a; a = a->next) + { + if (a->expr != NULL + && a->expr->rank > 0 + && resolve_assumed_size_actual (a->expr)) + return FAILURE; + } + } + if (t == SUCCESS) find_noncopying_intrinsics (c->resolved_sym, c->ext.actual); return t; @@ -2330,6 +2455,9 @@ resolve_variable (gfc_expr * e) e->ts = sym->ts; } + if (check_assumed_size_reference (sym, e)) + return FAILURE; + return SUCCESS; } @@ -4580,6 +4708,17 @@ resolve_symbol (gfc_symbol * sym) } break; + case FL_DERIVED: + /* Add derived type to the derived type list. */ + { + gfc_dt_list * dt_list; + dt_list = gfc_get_dt_list (); + dt_list->next = sym->ns->derived_types; + dt_list->derived = sym; + sym->ns->derived_types = dt_list; + } + break; + default: /* An external symbol falls through to here if it is not referenced. */ |