int i;
long int strlen, elements;
long int substrlen = 0;
+ bool is_str_storage = false;
gfc_ref *ref;
if (e == NULL)
if (ref->type == REF_SUBSTRING && ref->u.ss.start
&& ref->u.ss.start->expr_type == EXPR_CONSTANT)
{
- int len = strlen;
- if (ref->u.ss.end && ref->u.ss.end->expr_type == EXPR_CONSTANT)
- len = mpz_get_ui (ref->u.ss.end->value.integer);
- substrlen = len - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
+ if (is_str_storage)
+ {
+ /* The string length is the substring length.
+ Set now to full string length. */
+ if (ref->u.ss.length == NULL
+ || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
+ return 0;
+
+ strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
+ }
+ substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
continue;
}
return 0;
}
else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
- && e->expr_type == EXPR_VARIABLE
- && (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
- || e->symtree->n.sym->attr.pointer))
- elements = 1;
+ && e->expr_type == EXPR_VARIABLE)
+ {
+ if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+ || e->symtree->n.sym->attr.pointer)
+ {
+ elements = 1;
+ continue;
+ }
+
+ /* Determine the number of remaining elements in the element
+ sequence for array element designators. */
+ is_str_storage = true;
+ for (i = ref->u.ar.dimen - 1; i >= 0; i--)
+ {
+ if (ref->u.ar.start[i] == NULL
+ || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
+ || ref->u.ar.as->upper[i] == NULL
+ || ref->u.ar.as->lower[i] == NULL
+ || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
+ || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
+ return 0;
+
+ elements
+ = elements
+ * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+ - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+ + 1L)
+ - (mpz_get_si (ref->u.ar.start[i]->value.integer)
+ - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
+ }
+ }
else
- /* TODO: Determine the number of remaining elements in the element
- sequence for array element designators. See PR 32616.
- See also get_array_index in data.c. */
return 0;
}
if (substrlen)
- return elements*substrlen;
-
- return elements*strlen;
+ return (is_str_storage) ? substrlen + (elements-1)*strlen
+ : elements*strlen;
+ else
+ return elements*strlen;
}
is_elemental, where))
return 0;
+ /* Special case for character arguments. For allocatable, pointer
+ and assumed-shape dummies, the string length needs to match
+ exactly. */
if (a->expr->ts.type == BT_CHARACTER
&& a->expr->ts.cl && a->expr->ts.cl->length
&& a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
&& f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
- && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT
+ && (f->sym->attr.pointer || f->sym->attr.allocatable
+ || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+ && (mpz_cmp (a->expr->ts.cl->length->value.integer,
+ f->sym->ts.cl->length->value.integer) != 0))
{
- if ((f->sym->attr.pointer || f->sym->attr.allocatable)
- && (mpz_cmp (a->expr->ts.cl->length->value.integer,
- f->sym->ts.cl->length->value.integer) != 0))
- {
- if (where)
- gfc_warning ("Character length mismatch between actual "
- "argument and pointer or allocatable dummy "
- "argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 0;
- }
+ if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
+ gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+ "argument and pointer or allocatable dummy argument "
+ "'%s' at %L",
+ mpz_get_si (a->expr->ts.cl->length->value.integer),
+ mpz_get_si (f->sym->ts.cl->length->value.integer),
+ f->sym->name, &a->expr->where);
+ else if (where)
+ gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+ "argument and assumed-shape dummy argument '%s' "
+ "at %L",
+ mpz_get_si (a->expr->ts.cl->length->value.integer),
+ mpz_get_si (f->sym->ts.cl->length->value.integer),
+ f->sym->name, &a->expr->where);
+ return 0;
}
actual_size = get_expr_storage_size (a->expr);
{
if (where)
gfc_error ("Array-section actual argument with vector subscripts "
- "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
+ "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
"or VOLATILE attribute of the dummy argument '%s'",
&a->expr->where, f->sym->name);
return 0;
--- /dev/null
+! { dg-do compile }
+!
+! PR fortran/32616
+!
+! Check for to few elements of the actual argument
+! and reject mismatching string lengths for assumed-shape dummies
+!
+implicit none
+external test
+integer :: i(10)
+integer :: j(2,2)
+character(len=4) :: str(2)
+character(len=4) :: str2(2,2)
+
+call test()
+
+call foo(i(8)) ! { dg-warning "too few elements for dummy argument 'a' .3/4." }
+call foo(j(1,1))
+call foo(j(2,1)) ! { dg-warning "too few elements for dummy argument 'a' .3/4." }
+call foo(j(1,2)) ! { dg-warning "too few elements for dummy argument 'a' .2/4." }
+
+str = 'FORT'
+str2 = 'fort'
+call bar(str(:)(1:2)) ! { dg-warning "too few elements for dummy argument 'c' .4/6." }
+call bar(str(1:2)(1:1)) ! { dg-warning "too few elements for dummy argument 'c' .2/6." }
+call bar(str(2)) ! { dg-warning "too few elements for dummy argument 'c' .4/6." }
+call bar(str(1)(2:1)) ! OK
+call bar(str2(2,1)(4:1)) ! OK
+call bar(str2(1,2)(3:4)) ! OK
+call bar(str2(1,2)(4:4)) ! { dg-warning "too few elements for dummy argument 'c' .5/6." }
+contains
+ subroutine foo(a)
+ integer :: a(4)
+ end subroutine foo
+ subroutine bar(c)
+ character(len=2) :: c(3)
+! print '(3a)', ':',c(1),':'
+! print '(3a)', ':',c(2),':'
+! print '(3a)', ':',c(3),':'
+ end subroutine bar
+end
+
+
+subroutine test()
+implicit none
+character(len=5), pointer :: c
+character(len=5) :: str(5)
+call foo(c) ! { dg-error "Character length mismatch" }
+call bar(str) ! { dg-error "Character length mismatch" }
+contains
+ subroutine foo(a)
+ character(len=3), pointer :: a
+ end subroutine
+ subroutine bar(a)
+ character(len=3) :: a(:)
+ end subroutine bar
+end subroutine test
OSDN Git Service
