}
-/* Returns the storage size of a symbol (formal argument) or
- zero if it cannot be determined. */
+/* Returns the storage size of a symbol (formal argument) or sets argument
+ size_known to false if it cannot be determined. */
static unsigned long
-get_sym_storage_size (gfc_symbol *sym)
+get_sym_storage_size (gfc_symbol *sym, bool *size_known)
{
int i;
unsigned long strlen, elements;
+ *size_known = false;
+
if (sym->ts.type == BT_CHARACTER)
{
if (sym->ts.u.cl && sym->ts.u.cl->length
strlen = 1;
if (symbol_rank (sym) == 0)
- return strlen;
+ {
+ *size_known = true;
+ return strlen;
+ }
elements = 1;
if (sym->as->type != AS_EXPLICIT)
- mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
}
+ *size_known = true;
+
return strlen*elements;
}
-/* Returns the storage size of an expression (actual argument) or
- zero if it cannot be determined. For an array element, it returns
- the remaining size as the element sequence consists of all storage
+/* Returns the storage size of an expression (actual argument) or sets argument
+ size_known to false if it cannot be determined. For an array element, it
+ returns the remaining size as the element sequence consists of all storage
units of the actual argument up to the end of the array. */
static unsigned long
-get_expr_storage_size (gfc_expr *e)
+get_expr_storage_size (gfc_expr *e, bool *size_known)
{
int i;
long int strlen, elements;
bool is_str_storage = false;
gfc_ref *ref;
+ *size_known = false;
+
if (e == NULL)
return 0;
strlen = 1; /* Length per element. */
if (e->rank == 0 && !e->ref)
- return strlen;
+ {
+ *size_known = true;
+ return strlen;
+ }
elements = 1;
if (!e->ref)
return 0;
for (i = 0; i < e->rank; i++)
elements *= mpz_get_si (e->shape[i]);
- return elements*strlen;
+ {
+ *size_known = true;
+ return elements*strlen;
+ }
}
for (ref = e->ref; ref; ref = ref->next)
}
}
+ *size_known = true;
+
if (substrlen)
return (is_str_storage) ? substrlen + (elements-1)*strlen
: elements*strlen;
gfc_array_spec *fas, *aas;
bool pointer_dummy, pointer_arg, allocatable_arg;
bool procptr_dummy, optional_dummy, allocatable_dummy;
-
+ bool actual_size_known = false;
+ bool formal_size_known = false;
bool ok = true;
actual = *ap;
&& (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
f->sym->ts.u.cl->length->value.integer) != 0))
{
+ long actual_len, formal_len;
+ actual_len = mpz_get_si (a->expr->ts.u.cl->length->value.integer);
+ formal_len = mpz_get_si (f->sym->ts.u.cl->length->value.integer);
+
if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
- gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
- "argument and pointer or allocatable dummy argument "
- "%qs at %L",
- mpz_get_si (a->expr->ts.u.cl->length->value.integer),
- mpz_get_si (f->sym->ts.u.cl->length->value.integer),
- f->sym->name, &a->expr->where);
+ {
+ /* Emit a warning for -std=legacy and an error otherwise. */
+ if (gfc_option.warn_std == 0)
+ gfc_warning (0, "Character length mismatch (%ld/%ld) between "
+ "actual argument and pointer or allocatable "
+ "dummy argument %qs at %L", actual_len, formal_len,
+ f->sym->name, &a->expr->where);
+ else
+ gfc_error ("Character length mismatch (%ld/%ld) between "
+ "actual argument and pointer or allocatable "
+ "dummy argument %qs at %L", actual_len, formal_len,
+ f->sym->name, &a->expr->where);
+ }
else if (where)
- gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
- "argument and assumed-shape dummy argument %qs "
- "at %L",
- mpz_get_si (a->expr->ts.u.cl->length->value.integer),
- mpz_get_si (f->sym->ts.u.cl->length->value.integer),
- f->sym->name, &a->expr->where);
+ {
+ /* Emit a warning for -std=legacy and an error otherwise. */
+ if (gfc_option.warn_std == 0)
+ gfc_warning (0, "Character length mismatch (%ld/%ld) between "
+ "actual argument and assumed-shape dummy argument "
+ "%qs at %L", actual_len, formal_len,
+ f->sym->name, &a->expr->where);
+ else
+ gfc_error ("Character length mismatch (%ld/%ld) between "
+ "actual argument and assumed-shape dummy argument "
+ "%qs at %L", actual_len, formal_len,
+ f->sym->name, &a->expr->where);
+
+ }
ok = false;
goto match;
}
if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN)
goto skip_size_check;
- actual_size = get_expr_storage_size (a->expr);
- formal_size = get_sym_storage_size (f->sym);
- if (actual_size != 0 && actual_size < formal_size
- && a->expr->ts.type != BT_PROCEDURE
+ actual_size = get_expr_storage_size (a->expr, &actual_size_known);
+ formal_size = get_sym_storage_size (f->sym, &formal_size_known);
+
+ if (actual_size_known && formal_size_known
+ && actual_size != formal_size
+ && a->expr->ts.type == BT_CHARACTER
&& f->sym->attr.flavor != FL_PROCEDURE)
{
- if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
+ /* F2018:15.5.2.4:
+ (3) "The length type parameter values of a present actual argument
+ shall agree with the corresponding ones of the dummy argument that
+ are not assumed, except for the case of the character length
+ parameter of an actual argument of type character with default
+ kind or C character kind associated with a dummy argument that is
+ not assumed-shape or assumed-rank."
+
+ (4) "If a present scalar dummy argument is of type character with
+ default kind or C character kind, the length len of the dummy
+ argument shall be less than or equal to the length of the actual
+ argument. The dummy argument becomes associated with the leftmost
+ len characters of the actual argument. If a present array dummy
+ argument is of type character with default kind or C character
+ kind and is not assumed-shape or assumed-rank, it becomes
+ associated with the leftmost characters of the actual argument
+ element sequence."
+
+ As an extension we treat kind=4 character similarly to kind=1. */
+
+ if (actual_size > formal_size)
{
- gfc_warning (0, "Character length of actual argument shorter "
- "than of dummy argument %qs (%lu/%lu) at %L",
- f->sym->name, actual_size, formal_size,
- &a->expr->where);
+ if (a->expr->ts.type == BT_CHARACTER && where
+ && (!f->sym->as || f->sym->as->type == AS_EXPLICIT))
+ gfc_warning (OPT_Wcharacter_truncation,
+ "Character length of actual argument longer "
+ "than of dummy argument %qs (%lu/%lu) at %L",
+ f->sym->name, actual_size, formal_size,
+ &a->expr->where);
goto skip_size_check;
}
- else if (where)
+
+ if (a->expr->ts.type == BT_CHARACTER && where && !f->sym->as)
+ {
+ /* Emit warning for -std=legacy/gnu and an error otherwise. */
+ if (gfc_notification_std (GFC_STD_LEGACY) == ERROR)
+ {
+ gfc_error ("Character length of actual argument shorter "
+ "than of dummy argument %qs (%lu/%lu) at %L",
+ f->sym->name, actual_size, formal_size,
+ &a->expr->where);
+ ok = false;
+ goto match;
+ }
+ else
+ gfc_warning (0, "Character length of actual argument shorter "
+ "than of dummy argument %qs (%lu/%lu) at %L",
+ f->sym->name, actual_size, formal_size,
+ &a->expr->where);
+ goto skip_size_check;
+ }
+ }
+
+ if (actual_size_known && formal_size_known
+ && actual_size < formal_size
+ && f->sym->as
+ && a->expr->ts.type != BT_PROCEDURE
+ && f->sym->attr.flavor != FL_PROCEDURE)
+ {
+ if (where)
{
/* Emit a warning for -std=legacy and an error otherwise. */
if (gfc_option.warn_std == 0)
--- /dev/null
+! { dg-do compile }
+! { dg-additional-options "-std=f2018 -Wcharacter-truncation" }
+! PR fortran/93330
+!
+! Exercise compile-time checking of character length of dummy vs.
+! actual arguments. Based on original testcase by Tobias Burnus
+
+module m
+ use iso_c_binding, only: c_char
+ implicit none
+contains
+ ! scalar dummy
+ ! character(kind=1):
+ subroutine zero(x, y)
+ character(kind=1,len=0), value :: x
+ character(kind=1,len=1), value :: y
+ print '(5a)', 'zero >', x, '< >', y, '<'
+ end
+ subroutine one(x, y)
+ character(kind=1,len=1), value :: x
+ character(kind=1,len=1), value :: y
+ print '(5a)','one >', x, '< >', y, '<'
+ end
+ subroutine two(x, y)
+ character(kind=1,len=2), value :: x
+ character(kind=1,len=1), value :: y
+ print '(5a)','two >', x, '< >', y, '<'
+ end
+ subroutine cbind(x, y) bind(C)
+ character(kind=c_char,len=1), value :: x
+ character(kind=c_char,len=1), value :: y
+ print '(5a)','cbind >', x, '< >', y, '<'
+ end
+
+ ! character(kind=4):
+ subroutine zero4(x, y)
+ character(kind=4,len=0), value :: x
+ character(kind=1,len=1), value :: y
+ print '(5a)', 'zero4 >', x, '< >', y, '<'
+ end
+ subroutine one4(x, y)
+ character(kind=4,len=1), value :: x
+ character(kind=1,len=1), value :: y
+ print '(5a)','one4 >', x, '< >', y, '<'
+ end
+ subroutine two4(x, y)
+ character(kind=4,len=2), value :: x
+ character(kind=1,len=1), value :: y
+ print '(5a)','two4 >', x, '< >', y, '<'
+ end
+
+ ! character(kind=1):
+ ! array dummy, assumed size
+ subroutine zero_0(x, y)
+ character(kind=1,len=0) :: x(*)
+ character(kind=1,len=1), value :: y
+ print '(5a)', 'zero_0 >', x(1), '< >', y, '<'
+ end
+ subroutine one_0(x, y)
+ character(kind=1,len=1) :: x(*)
+ character(kind=1,len=1), value :: y
+ print '(5a)','one_0 >', x(1), '< >', y, '<'
+ end
+ subroutine two_0(x, y)
+ character(kind=1,len=2) :: x(*)
+ character(kind=1,len=1), value :: y
+ print '(5a)','two_0 >', x(1), '< >', y, '<'
+ end
+
+ ! array dummy, explicit size
+ subroutine zero_1(x, y)
+ character(kind=1,len=0) :: x(1)
+ character(kind=1,len=1), value :: y
+ print '(5a)', 'zero_1 >', x(1), '< >', y, '<'
+ end
+ subroutine one_1(x, y)
+ character(kind=1,len=1) :: x(1)
+ character(kind=1,len=1), value :: y
+ print '(5a)','one_1 >', x(1), '< >', y, '<'
+ end
+ subroutine two_1(x, y)
+ character(kind=1,len=2) :: x(1)
+ character(kind=1,len=1), value :: y
+ print '(5a)','two_1 >', x(1), '< >', y, '<'
+ end
+
+ ! array dummy, assumed shape
+ subroutine zero_a(x, y)
+ character(kind=1,len=0) :: x(:)
+ character(kind=1,len=1), value :: y
+ if (size (x) < 1) stop 99
+ print '(5a)', 'zero_a >', x(1), '< >', y, '<'
+ end
+ subroutine one_a(x, y)
+ character(kind=1,len=1) :: x(:)
+ character(kind=1,len=1), value :: y
+ if (size (x) < 1) stop 99
+ print '(5a)','one_a >', x(1), '< >', y, '<'
+ end
+ subroutine two_a(x, y)
+ character(kind=1,len=2) :: x(:)
+ character(kind=1,len=1), value :: y
+ if (size (x) < 1) stop 99
+ print '(5a)','two_a >', x(1), '< >', y, '<'
+ end
+
+ ! character(kind=4):
+ ! array dummy, assumed size
+ subroutine zero4_0(x, y)
+ character(kind=4,len=0) :: x(*)
+ character(kind=4,len=1), value :: y
+ print '(5a)', 'zero4_0 >', x(1), '< >', y, '<'
+ end
+ subroutine one4_0(x, y)
+ character(kind=4,len=1) :: x(*)
+ character(kind=4,len=1), value :: y
+ print '(5a)','one4_0 >', x(1), '< >', y, '<'
+ end
+ subroutine two4_0(x, y)
+ character(kind=4,len=2) :: x(*)
+ character(kind=4,len=1), value :: y
+ print '(5a)','two4_0 >', x(1), '< >', y, '<'
+ end
+
+ ! array dummy, explicit size
+ subroutine zero4_1(x, y)
+ character(kind=4,len=0) :: x(1)
+ character(kind=4,len=1), value :: y
+ print '(5a)', 'zero4_1 >', x(1), '< >', y, '<'
+ end
+ subroutine one4_1(x, y)
+ character(kind=4,len=1) :: x(1)
+ character(kind=4,len=1), value :: y
+ print '(5a)','one4_1 >', x(1), '< >', y, '<'
+ end
+ subroutine two4_1(x, y)
+ character(kind=4,len=2) :: x(1)
+ character(kind=4,len=1), value :: y
+ print '(5a)','two4_1 >', x(1), '< >', y, '<'
+ end
+
+ ! array dummy, assumed shape
+ subroutine zero4_a(x, y)
+ character(kind=4,len=0) :: x(:)
+ character(kind=4,len=1), value :: y
+ if (size (x) < 1) stop 99
+ print '(5a)', 'zero4_a >', x(1), '< >', y, '<'
+ end
+ subroutine one4_a(x, y)
+ character(kind=4,len=1) :: x(:)
+ character(kind=4,len=1), value :: y
+ if (size (x) < 1) stop 99
+ print '(5a)','one4_a >', x(1), '< >', y, '<'
+ end
+ subroutine two4_a(x, y)
+ character(kind=4,len=2) :: x(:)
+ character(kind=4,len=1), value :: y
+ if (size (x) < 1) stop 99
+ print '(5a)','two4_a >', x(1), '< >', y, '<'
+ end
+end
+
+program p
+ use m
+ implicit none
+ call zero('', '1')
+ call one ('', '2') ! { dg-error "length of actual argument shorter" }
+ call one ('b'(3:2),'3') ! { dg-error "length of actual argument shorter" }
+ call two ('', '4') ! { dg-error "length of actual argument shorter" }
+ call two ('f','5') ! { dg-error "length of actual argument shorter" }
+
+ call cbind('', '6') ! { dg-error "length of actual argument shorter" }
+ call cbind('ABC','7') ! { dg-warning "length of actual argument longer" }
+
+ ! character(kind=4):
+ call zero4(4_'', '8')
+ call zero4(4_'3','9') ! { dg-warning "length of actual argument longer" }
+ call one4 (4_'', 'A') ! { dg-error "length of actual argument shorter" }
+ call one4 (4_'b'(3:2),'B') ! { dg-error "length of actual argument shorter" }
+ call one4 (4_'bbcd'(3:3),'C')
+ call one4 (4_'cd','D') ! { dg-warning "length of actual argument longer" }
+ call two4 (4_'', 'E') ! { dg-error "length of actual argument shorter" }
+ call two4 (4_'f', 'F') ! { dg-error "length of actual argument shorter" }
+ call two4 (4_'fgh','G') ! { dg-warning "length of actual argument longer" }
+
+ ! array dummy, assumed size
+ call zero_0([''],'a')
+ call zero_0(['a'],'b')
+ call one_0 ([''],'c')
+ call one_0 (['b'],'d')
+ call one_0 (['cd'],'e')
+ call two_0 ([''],'f')
+ call two_0 (['fg'],'g')
+
+ ! array dummy, explicit size
+ call zero_1([''],'a')
+ call zero_1(['a'],'b') ! { dg-warning "actual argument longer" }
+ call one_1 ([''],'c') ! { dg-error "too few elements for dummy" }
+ call one_1 (['b'],'d')
+ call one_1 (['cd'],'e') ! { dg-warning "actual argument longer" }
+ call two_1 ([''],'f') ! { dg-error "too few elements for dummy" }
+ call two_1 (['fg'],'h')
+
+ ! array dummy, assumed shape
+ call zero_a([''],'a')
+ call zero_a(['a'],'b') ! { dg-error "Character length mismatch" }
+ call one_a ([''],'c') ! { dg-error "Character length mismatch" }
+ call one_a (['b'],'d')
+ call one_a (['cd'],'e') ! { dg-error "Character length mismatch" }
+ call two_a ([''],'f') ! { dg-error "Character length mismatch" }
+ call two_a (['fg'],'h')
+
+ ! character(kind=4):
+ ! array dummy, assumed size
+ call zero4_0([4_''],4_'a')
+ call zero4_0([4_'a'],4_'b')
+ call one4_0 ([4_''],4_'c')
+ call one4_0 ([4_'b'],4_'d')
+ call one4_0 ([4_'cd'],4_'e')
+ call two4_0 ([4_''],4_'f')
+ call two4_0 ([4_'fg'],4_'g')
+
+ ! array dummy, explicit size
+ call zero4_1([4_''],4_'a')
+ call zero4_1([4_'a'],4_'b') ! { dg-warning "actual argument longer" }
+ call one4_1 ([4_''],4_'c') ! { dg-error "too few elements for dummy" }
+ call one4_1 ([4_'b'],4_'d')
+ call one4_1 ([4_'cd'],4_'e') ! { dg-warning "actual argument longer" }
+ call two4_1 ([4_''],4_'f') ! { dg-error "too few elements for dummy" }
+ call two4_1 ([4_'fg'],4_'h')
+
+ ! array dummy, assumed shape
+ call zero4_a([4_''],4_'a')
+ call zero4_a([4_'a'],4_'b') ! { dg-error "Character length mismatch" }
+ call one4_a ([4_''],4_'c') ! { dg-error "Character length mismatch" }
+ call one4_a ([4_'b'],4_'d')
+ call one4_a ([4_'cd'],4_'e') ! { dg-error "Character length mismatch" }
+ call two4_a ([4_''],4_'f') ! { dg-error "Character length mismatch" }
+ call two4_a ([4_'fg'],4_'h')
+end
projects / thirdparty / gcc.git / commitdiff
