procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Character typenames in errors and warnings

Browse source 
Character type names now incorporate length, kind is only shown if
the default character is not being used.
    
Examples:
   
  character(7) is reported as CHARACTER(7)
  character(len=20,kind=4) is reported as CHARACTER(20,4)
   
dummy character variables with assumed length:
    
  character(*) is reported as CHARACTER(*)
  character(*,kind=4) is reported as CHARACTER(*,4)

From-SVN: r276505
This commit is contained in:
Mark Eggleston 2019-10-03 09:40:23 +00:00 • committed by Mark Eggleston
parent 38a734350f
commit f61e54e59c
19 changed files with 373 additions and 58 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
gcc/fortran/ChangeLog
View file

@ -1,3 +1,47 @@
2019-10-03 Mark Eggleston <mark.eggleston@codethink.com>
* array.c (check_element_type): Call gfc_typename with the gfc_expr
"expr" instead of its gfc_typespec "ts".
* check.c (gfc_check_co_reduce): Call gfc_typename with the gfc_expr
"a" instead of its gfc_typespec "ts".
(gfc_check_co_reduce): Call gfc_typename with the gfc_expr "a" instead
of its gfc_typespec "ts".
(gfc_check_eoshift): Call gfc_typename with the gfc_expr "array"
instead of its gfc_typespec ts.
(gfc_check_same_type_as): In two calls to gfc_typename use "a" and "b"
of type gfc_expr instead of the "ts" fields of "a" and "b"
* decl.c (variable_decl): Call gfc_typename with the gfc_expr
"initializer" instead of its gfc_typespec "ts".
* expr.c (gfc_check_assign): Use "rvalue" and "lvalue" of type gfc_expr
in calls to gfc_typename instead of their "ts" fields of type
gfc_typespec.
(gfc_check_pointer_assign): Use "rvalue" and "lvalue" of type gfc_expr
in calls to gfc_typename instead of their "ts" fields of type
gfc_typespec.
* gfortran.h: Add prototypes for gfc_dummy_typename and a new function
gfc_typename for gfc_expr *.
*interface.c (gfc_check_dummy_characteristics): Use gfc_dummy_typename
for the dummy variable.
(compare_parameter): Use gfc_dummy_typename for the formal argument.
Use "actual" of type gfc_expr in call to gfc_typename for the actual
argument.
* intrinsic.c (check_arglist): Use gfc_dummy_typename for the formal
argument. Use expressions of type gfc_expr from the argument list to
call gfc_typename.
(gfc_convert_type_warn): New local variable "is_char_constant" set if
the expression type is a character constant. At the "bad" label
determine source type name by calling gfc_typename with either "expr"
for character constants or "from_ts" and use that in the warning
messages instead of the original call to gfc_typename.
* misc.c (gfc_typename): New function for gfc_expr *, use for where
character types are possible it can get the character length from
gfc_expr for character literals.
(gfc_dummy_typename): New functionfor gfc_typespec *, if no character
length is present the character type is assumed and the appropriate
string is return otherwise it calls gfc_typename for gfc_typespec *.
(gfc_typespec): for character types construct the type name with length
and kind (if it is not default kind).
2019-10-02 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/91784

2
gcc/fortran/array.c
View file

@ -1358,7 +1358,7 @@ check_element_type (gfc_expr *expr, bool convert)
gfc_error ("Element in %s array constructor at %L is %s",
gfc_typename (&constructor_ts), &expr->where,
gfc_typename (&expr->ts));
gfc_typename (expr));
cons_state = CONS_BAD;
return 1;

10
gcc/fortran/check.c
View file

@ -2266,7 +2266,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
{
gfc_error ("The A argument at %L has type %s but the function passed as "
"OPERATOR at %L returns %s",
&a->where, gfc_typename (&a->ts), &op->where,
&a->where, gfc_typename (a), &op->where,
gfc_typename (&sym->result->ts));
return false;
}
@ -2276,7 +2276,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
gfc_error ("The function passed as OPERATOR at %L has arguments of type "
"%s and %s but shall have type %s", &op->where,
gfc_typename (&formal->sym->ts),
gfc_typename (&formal->next->sym->ts), gfc_typename (&a->ts));
gfc_typename (&formal->next->sym->ts), gfc_typename (a));
return false;
}
if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
@ -2844,7 +2844,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
"of type %qs", gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic, &array->where,
gfc_current_intrinsic_arg[0]->name,
gfc_typename (&array->ts));
gfc_typename (array));
return false;
}
}
@ -4808,7 +4808,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
&a->where, gfc_typename (&a->ts));
&a->where, gfc_typename (a));
return false;
}
@ -4827,7 +4827,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
&b->where, gfc_typename (&b->ts));
&b->where, gfc_typename (b));
return false;
}

2
gcc/fortran/decl.c
View file

@ -2908,7 +2908,7 @@ variable_decl (int elem)
{
gfc_error ("Incompatible initialization between a derived type "
"entity and an entity with %qs type at %C",
gfc_typename (&initializer->ts));
gfc_typename (initializer));
m = MATCH_ERROR;
goto cleanup;
}

8
gcc/fortran/expr.c
View file

@ -3693,8 +3693,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
return true;
gfc_error ("BOZ literal constant near %L cannot be assigned to a "
"%qs variable", &rvalue->where, gfc_typename (&lvalue->ts));
"%qs variable", &rvalue->where, gfc_typename (lvalue));
return false;
}
@ -3726,7 +3725,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
where = lvalue->where.lb ? &lvalue->where : &rvalue->where;
gfc_error ("Incompatible types in DATA statement at %L; attempted "
"conversion of %s to %s", where,
gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
gfc_typename (rvalue), gfc_typename (lvalue));
return false;
}
@ -4139,8 +4138,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
else if (!suppress_type_test)
gfc_error ("Different types in pointer assignment at %L; "
"attempted assignment of %s to %s", &lvalue->where,
gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts));
gfc_typename (rvalue), gfc_typename (lvalue));
return false;
}

2
gcc/fortran/gfortran.h
View file

@ -2884,7 +2884,9 @@ void gfc_end_source_files (void);
void gfc_clear_ts (gfc_typespec *);
FILE *gfc_open_file (const char *);
const char *gfc_basic_typename (bt);
const char *gfc_dummy_typename (gfc_typespec *);
const char *gfc_typename (gfc_typespec *);
const char *gfc_typename (gfc_expr *);
const char *gfc_op2string (gfc_intrinsic_op);
const char *gfc_code2string (const mstring *, int);
int gfc_string2code (const mstring *, const char *);

11
gcc/fortran/interface.c
View file

@ -1330,7 +1330,8 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
|| !compare_type_characteristics (s2, s1))
{
snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts));
s1->name, gfc_dummy_typename (&s1->ts),
gfc_dummy_typename (&s2->ts));
return false;
}
if (!compare_rank (s1, s2))
@ -2338,15 +2339,15 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
"and actual argument at %L (%s/%s).",
&actual->where,
&formal->declared_at,
gfc_typename (&actual->ts),
gfc_typename (&formal->ts));
gfc_typename (actual),
gfc_dummy_typename (&formal->ts));
formal->error = 1;
}
else
gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s "
"to %s", formal->name, where, gfc_typename (&actual->ts),
gfc_typename (&formal->ts));
"to %s", formal->name, where, gfc_typename (actual),
gfc_dummy_typename (&formal->ts));
}
return false;
}

27
gcc/fortran/intrinsic.c
View file

@ -4363,11 +4363,12 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
if (!gfc_compare_types (&ts, &actual->expr->ts))
{
if (error_flag)
gfc_error ("Type of argument %qs in call to %qs at %L should "
"be %s, not %s", gfc_current_intrinsic_arg[i]->name,
gfc_current_intrinsic, &actual->expr->where,
gfc_typename (&formal->ts),
gfc_typename (&actual->expr->ts));
gfc_error ("In call to %qs at %L, type mismatch in argument "
"%qs; pass %qs to %qs", gfc_current_intrinsic,
&actual->expr->where,
gfc_current_intrinsic_arg[i]->name,
gfc_typename (actual->expr),
gfc_dummy_typename (&formal->ts));
return false;
}
@ -5076,6 +5077,8 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
gfc_expr *new_expr;
int rank;
mpz_t *shape;
bool is_char_constant = (expr->expr_type == EXPR_CONSTANT)
&& (expr->ts.type == BT_CHARACTER);
from_ts = expr->ts; /* expr->ts gets clobbered */
@ -5117,7 +5120,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
if ((gfc_option.warn_std & sym->standard) != 0)
{
gfc_warning_now (0, "Extension: Conversion from %s to %s at %L",
gfc_typename (&from_ts), gfc_typename (ts),
gfc_typename (&from_ts), gfc_dummy_typename (ts),
&expr->where);
}
else if (wflag)
@ -5179,7 +5182,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
/* If HOLLERITH is involved, all bets are off. */
if (warn_conversion)
gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L",
gfc_typename (&from_ts), gfc_typename (ts),
gfc_typename (&from_ts), gfc_dummy_typename (ts),
&expr->where);
}
else
@ -5231,15 +5234,17 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
return true;
bad:
const char *type_name = is_char_constant ? gfc_typename (expr)
: gfc_typename (&from_ts);
if (eflag == 1)
{
gfc_error ("Cannot convert %s to %s at %L",
gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
gfc_error ("Cannot convert %s to %s at %L", type_name, gfc_typename (ts),
&expr->where);
return false;
}
gfc_internal_error ("Cannot convert %qs to %qs at %L",
gfc_typename (&from_ts), gfc_typename (ts),
gfc_internal_error ("Cannot convert %qs to %qs at %L", type_name,
gfc_typename (ts),
&expr->where);
/* Not reached */
}

71
gcc/fortran/misc.c
View file

@ -129,6 +129,7 @@ gfc_typename (gfc_typespec *ts)
static int flag = 0;
char *buffer;
gfc_typespec *ts1;
gfc_charlen_t length = 0;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
@ -148,7 +149,13 @@ gfc_typename (gfc_typespec *ts)
sprintf (buffer, "LOGICAL(%d)", ts->kind);
break;
case BT_CHARACTER:
sprintf (buffer, "CHARACTER(%d)", ts->kind);
if (ts->u.cl && ts->u.cl->length)
length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
if (ts->kind == gfc_default_character_kind)
sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
else
sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
ts->kind);
break;
case BT_HOLLERITH:
sprintf (buffer, "HOLLERITH");
@ -186,6 +193,68 @@ gfc_typename (gfc_typespec *ts)
}
const char *
gfc_typename (gfc_expr *ex)
{
/* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
add 19 for the extra width and 1 for '\0' */
static char buffer1[34];
static char buffer2[34];
static bool flag = false;
char *buffer;
gfc_charlen_t length;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
if (ex->ts.type == BT_CHARACTER)
{
if (ex->ts.u.cl && ex->ts.u.cl->length)
length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
else
length = ex->value.character.length;
if (ex->ts.kind == gfc_default_character_kind)
sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
else
sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
ex->ts.kind);
return buffer;
}
return gfc_typename(&ex->ts);
}
/* The type of a dummy variable can also be CHARACTER(*). */
const char *
gfc_dummy_typename (gfc_typespec *ts)
{
static char buffer1[15]; /* 15 for "CHARACTER(*,4)" + '\0'. */
static char buffer2[15];
static bool flag = false;
char *buffer;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
if (ts->type == BT_CHARACTER)
{
bool has_length = false;
if (ts->u.cl)
has_length = ts->u.cl->length != NULL;
if (!has_length)
{
if (ts->kind == gfc_default_character_kind)
sprintf(buffer, "CHARACTER(*)");
else if (ts->kind < 10)
sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
else
sprintf(buffer, "CHARACTER(*,?)");
return buffer;
}
}
return gfc_typename(ts);
}
/* Given an mstring array and a code, locate the code in the table,
returning a pointer to the string. */

32
gcc/fortran/resolve.c
View file

@ -3980,7 +3980,7 @@ resolve_operator (gfc_expr *e)
}
sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
gfc_op2string (e->value.op.op), gfc_typename (e));
goto bad_op;
case INTRINSIC_PLUS:
@ -4002,8 +4002,8 @@ resolve_operator (gfc_expr *e)
else
sprintf (msg,
_("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
gfc_op2string (e->value.op.op), gfc_typename (op1),
gfc_typename (op2));
goto bad_op;
case INTRINSIC_CONCAT:
@ -4017,7 +4017,7 @@ resolve_operator (gfc_expr *e)
sprintf (msg,
_("Operands of string concatenation operator at %%L are %s/%s"),
gfc_typename (&op1->ts), gfc_typename (&op2->ts));
gfc_typename (op1), gfc_typename (op2));
goto bad_op;
case INTRINSIC_AND:
@ -4059,8 +4059,8 @@ resolve_operator (gfc_expr *e)
}
sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
gfc_op2string (e->value.op.op), gfc_typename (op1),
gfc_typename (op2));
goto bad_op;
@ -4082,7 +4082,7 @@ resolve_operator (gfc_expr *e)
}
sprintf (msg, _("Operand of .not. operator at %%L is %s"),
gfc_typename (&op1->ts));
gfc_typename (op1));
goto bad_op;
case INTRINSIC_GT:
@ -4168,7 +4168,7 @@ resolve_operator (gfc_expr *e)
msg = "Inequality comparison for %s at %L";
gfc_warning (OPT_Wcompare_reals, msg,
gfc_typename (&op1->ts), &op1->where);
gfc_typename (op1), &op1->where);
}
}
@ -4184,8 +4184,8 @@ resolve_operator (gfc_expr *e)
else
sprintf (msg,
_("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
gfc_op2string (e->value.op.op), gfc_typename (op1),
gfc_typename (op2));
goto bad_op;
@ -4203,12 +4203,12 @@ resolve_operator (gfc_expr *e)
}
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
e->value.op.uop->name, gfc_typename (op1));
else
{
sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
e->value.op.uop->name, gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
e->value.op.uop->name, gfc_typename (op1),
gfc_typename (op2));
e->value.op.uop->op->sym->attr.referenced = 1;
}
@ -8509,7 +8509,7 @@ resolve_select (gfc_code *code, bool select_type)
if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
{
gfc_error ("Argument of SELECT statement at %L cannot be %s",
&case_expr->where, gfc_typename (&case_expr->ts));
&case_expr->where, gfc_typename (case_expr));
/* Punt. Going on here just produce more garbage error messages. */
return;
@ -8538,7 +8538,7 @@ resolve_select (gfc_code *code, bool select_type)
case_expr->ts.kind) != ARITH_OK)
gfc_warning (0, "Expression in CASE statement at %L is "
"not in the range of %s", &cp->low->where,
gfc_typename (&case_expr->ts));
gfc_typename (case_expr));
if (cp->high
&& cp->low != cp->high
@ -8546,7 +8546,7 @@ resolve_select (gfc_code *code, bool select_type)
case_expr->ts.kind) != ARITH_OK)
gfc_warning (0, "Expression in CASE statement at %L is "
"not in the range of %s", &cp->high->where,
gfc_typename (&case_expr->ts));
gfc_typename (case_expr));
}
/* PR 19168 has a long discussion concerning a mismatch of the kinds

14
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,17 @@
2019-10-03 Mark Eggleston <mark.eggleston@codethink.com>
* gfortran.dg/bad_operands.f90: New test.
* gfortran.dg/character mismatch.f90: New test.
* gfortran.dg/compare_interfaces.f90: New test.
* gfortran.dg/hollerith_to_char_parameter_1.f90: New test.
* gfortran.dg/hollerith_to_char_parameter_2.f90: New test.
* gfortran.dg/widechar_intrinsics_1.f90: Checked for specific character
type names instead of "Type of argument".
* gfortran.dg/widechar_intrinsics_2.f90: Checked for specific character
type names instead of "Type of argument".
* gfortran.dg/widechar_intrinsics_3.f90: Checked for specific character
type names instead of "Type of argument".
2019-10-02 Joseph Myers <joseph@codesourcery.com>
* gcc.dg/cr-decimal-dig-2.c: New test.

10
gcc/testsuite/gfortran.dg/bad_operands.f90 Normal file
View file

@ -0,0 +1,10 @@
! { dg-do compile }
!
! Test case contributed by Mark Eggleston <mark.eggleston@codethink.com>
program test
integer(4) :: x
x = x // "rubbish" ! { dg-error "INTEGER\\(4\\)/CHARACTER\\(7\\)" }
x = 4_"more rubbish" + 6 ! { dg-error "CHARACTER\\(12,4\\)/INTEGER\\(4\\)" }
end program

76
gcc/testsuite/gfortran.dg/character_mismatch.f90 Normal file
View file

@ -0,0 +1,76 @@
! { dg-do compile }
!
! Test case contributed by Mark Eggleston <mark.eggleston@codethink.com>
program test
use iso_fortran_env
implicit none
integer, parameter :: ucs4 = selected_char_kind('ISO_10646')
integer :: x
character(len=7) :: s = "abcd123"
character(4, ucs4) :: s4 = char(int(z'20ac'), ucs4) // ucs4_"100"
x = s
x = "string"
x = "A longer string" // " plus a bit"
x = s // s
x = s // "a bit more"
x = "prefix:" // s
x = s4
x = ucs4_"string"
x = ucs4_"A longer string" // ucs4_" plus a bit"
x = s4 // s4
x = s4 // ucs4_"a bit more"
x = ucs4_"prefix:" // s4
call f(s)
call f("string")
call f("A longer string" // " plus a bit")
call f(s // s)
call f(s // "a bit more")
call f("a string:" // s)
call f(s4)
call f(ucs4_"string")
call f(ucs4_"A longer string" // ucs4_" plus a bit")
call f(s4 // s4)
call f(s4 // ucs4_"a bit more")
call f(ucs4_"a string:" // s4)
write(*,*) "" // ucs4_""
contains
subroutine f(y)
integer, intent(in) :: y
write(*,*) y
end subroutine f
end program
! { dg-error "CHARACTER\\(7\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 13 }
! { dg-error "CHARACTER\\(6\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 14 }
! { dg-error "CHARACTER\\(26\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 15 }
! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 16 }
! { dg-error "CHARACTER\\(17\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 17 }
! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 18 }
! { dg-error "CHARACTER\\(4,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 19 }
! { dg-error "CHARACTER\\(6,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 20 }
! { dg-error "CHARACTER\\(26,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 21 }
! { dg-error "CHARACTER\\(8,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 22 }
! { dg-error "CHARACTER\\(14,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 23 }
! { dg-error "CHARACTER\\(11,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 24 }
! { dg-error "CHARACTER\\(7\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 26 }
! { dg-error "CHARACTER\\(6\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 27 }
! { dg-error "CHARACTER\\(26\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 28 }
! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 29 }
! { dg-error "CHARACTER\\(17\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 30 }
! { dg-error "CHARACTER\\(16\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 31 }
! { dg-error "CHARACTER\\(4,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 33 }
! { dg-error "CHARACTER\\(6,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 34 }
! { dg-error "CHARACTER\\(26,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 35 }
! { dg-error "CHARACTER\\(8,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 36 }
! { dg-error "CHARACTER\\(14,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 37 }
! { dg-error "CHARACTER\\(13,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 38 }
! { dg-error "CHARACTER\\(0\\)/CHARACTER\\(0,4\\)" "operand type mismatch" { target \*-\*-\* } 40 }

73
gcc/testsuite/gfortran.dg/compare_interfaces.f90 Normal file
View file

@ -0,0 +1,73 @@
! { dg-do compile }
!
! Contributed by Mark Eggleston <mark.eggleston@codethink.co.uk>
subroutine f(a, b)
integer :: a
real :: b
write(*,*) a, b
end subroutine
subroutine g(a, b)
integer :: a
character(*) :: b
write(*,*) a, b
end subroutine
subroutine h
interface
subroutine f(a, b) ! { dg-error "\\(CHARACTER\\(\\*\\)/REAL\\(4\\)\\)" }
integer :: a
character(*) :: b
end subroutine
subroutine g(a, b) ! { dg-error "\\(REAL\\(4\\)/CHARACTER\\(\\*\\)\\)" }
integer :: a
real :: b
end subroutine
end interface
call f(6, 6.0)
call g(6, "abcdef")
end subroutine
subroutine f4(a, b)
integer :: a
real :: b
write(*,*) a, b
end subroutine
subroutine g4(a, b)
integer :: a
character(*,4) :: b
write(*,*) a, b
end subroutine
subroutine h4
interface
subroutine f4(a, b) ! { dg-error "\\(CHARACTER\\(\\*,4\\)/REAL\\(4\\)\\)" }
integer :: a
character(*,4) :: b
end subroutine
subroutine g4(a, b) ! { dg-error "REAL\\(4\\)/CHARACTER\\(\\*,4\\)" }
integer :: a
real :: b
end subroutine
end interface
call f4(6, 6.0)
call g4(6, 4_"abcdef")
end subroutine
program test
call h
call h4
end program
! { dg-error "passed REAL\\(4\\) to CHARACTER\\(\\*\\)" "type mismatch" { target \*-\*-\* } 31 }
! { dg-error "passed CHARACTER\\(6\\) to REAL\\(4\\)" "type mismatch" { target \*-\*-\* } 32 }
! { dg-error "passed REAL\\(4\\) to CHARACTER\\(\\*,4\\)" "type mismatch" { target \*-\*-\* } 61 }
! { dg-error "passed CHARACTER\\(6,4\\) to REAL\\(4\\)" "type mismatch" { target \*-\*-\* } 62 }

11
gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f90 Normal file
View file

@ -0,0 +1,11 @@
! { dg-do compile }
! { dg-options "-Wconversion -std=legacy" }
!
! Test case contributed by Mark Eggleston <mark.eggleston@codethink.com>
program test
character(*), parameter :: h = 5hABCDE ! { dg-warning "HOLLERITH to CHARACTER\\(\\*\\)" }
write(*,*) h
end program

12
gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f90 Normal file
View file

@ -0,0 +1,12 @@
! { dg-do compile }
!
! Test case contributed by Mark Eggleston <mark.eggleston@codethink.com>
program test
character(*), parameter :: h = 5hABCDE ! { dg-warning "HOLLERITH to CHARACTER\\(\\*\\)" }
write(*,*) h
end program
! { dg-warning "Legacy Extension" "extension" { target \*-\*-\* } 6 }

12
gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90
View file

@ -15,18 +15,18 @@
call date_and_time(s4, t4, u4) ! { dg-error "must be of kind 1" }
call get_command(s1)
call get_command(s4) ! { dg-error "Type of argument" }
call get_command(s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call get_command_argument(1, s1)
call get_command_argument(1, s4) ! { dg-error "Type of argument" }
call get_command_argument(1, s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call get_environment_variable("PATH", s1)
call get_environment_variable(s1)
call get_environment_variable(s1, t1)
call get_environment_variable(4_"PATH", s1) ! { dg-error "Type of argument" }
call get_environment_variable(s4) ! { dg-error "Type of argument" }
call get_environment_variable(s1, t4) ! { dg-error "Type of argument" }
call get_environment_variable(s4, t1) ! { dg-error "Type of argument" }
call get_environment_variable(4_"PATH", s1) ! { dg-error "'CHARACTER\\(4,4\\)' to 'CHARACTER\\(\\*\\)'" }
call get_environment_variable(s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call get_environment_variable(s1, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call get_environment_variable(s4, t1) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
print *, lge(s1,t1)
print *, lge(s1,"foo")

10
gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90
View file

@ -38,9 +38,9 @@ program failme
call getcwd (s4, i) ! { dg-error "must be of kind" }
call getenv (s1, t1)
call getenv (s1, t4) ! { dg-error "Type of argument" }
call getenv (s4, t1) ! { dg-error "Type of argument" }
call getenv (s4, t4) ! { dg-error "Type of argument" }
call getenv (s1, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call getenv (s4, t1) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call getenv (s4, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call getarg (i, s1)
call getarg (i, s4) ! { dg-error "must be of kind" }
@ -115,8 +115,8 @@ program failme
call system (s1)
call system (s1, i)
call system (s4) ! { dg-error "Type of argument" }
call system (s4, i) ! { dg-error "Type of argument" }
call system (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call system (s4, i) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
call ttynam (i, s1)
call ttynam (i, s4) ! { dg-error "must be of kind" }

4
gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90
View file

@ -35,7 +35,7 @@ program failme
print *, fputc (i, s4) ! { dg-error "must be of kind" }
print *, getcwd (s1)
print *, getcwd (s4) ! { dg-error "Type of argument" }
print *, getcwd (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
print *, hostnm (s1)
print *, hostnm (s4) ! { dg-error "must be of kind" }
@ -61,7 +61,7 @@ program failme
print *, symlnk (s4, t4) ! { dg-error "must be of kind" }
print *, system (s1)
print *, system (s4) ! { dg-error "Type of argument" }
print *, system (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
print *, unlink (s1)
print *, unlink (s4) ! { dg-error "must be of kind" }