aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog44
-rw-r--r--gcc/fortran/array.c2
-rw-r--r--gcc/fortran/check.c10
-rw-r--r--gcc/fortran/decl.c2
-rw-r--r--gcc/fortran/expr.c8
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/interface.c11
-rw-r--r--gcc/fortran/intrinsic.c27
-rw-r--r--gcc/fortran/misc.c71
-rw-r--r--gcc/fortran/resolve.c32
-rw-r--r--gcc/testsuite/ChangeLog14
-rw-r--r--gcc/testsuite/gfortran.dg/bad_operands.f9010
-rw-r--r--gcc/testsuite/gfortran.dg/character_mismatch.f9076
-rw-r--r--gcc/testsuite/gfortran.dg/compare_interfaces.f9073
-rw-r--r--gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f9011
-rw-r--r--gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f9012
-rw-r--r--gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f9012
-rw-r--r--gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f9010
-rw-r--r--gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f904
19 files changed, 373 insertions, 58 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ea1177f..64812f2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index ba8a816..3a504eb 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -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;
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 98203bc..87a8196 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -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;
}
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 3ba61a0..96b6f3f 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -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;
}
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 5d3480e..9f638fe 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -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;
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a70978b..d84d1fa 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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 *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 08e4f06..3313e72 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -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;
}
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 764e350..ac5af10 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -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 */
}
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index eed203d..97df9ee 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -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. */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a792547..20ecafd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e57cc72..10de7b9 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.
diff --git a/gcc/testsuite/gfortran.dg/bad_operands.f90 b/gcc/testsuite/gfortran.dg/bad_operands.f90
new file mode 100644
index 0000000..e82a07f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bad_operands.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/character_mismatch.f90 b/gcc/testsuite/gfortran.dg/character_mismatch.f90
new file mode 100644
index 0000000..e1619467
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/character_mismatch.f90
@@ -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 }
+
diff --git a/gcc/testsuite/gfortran.dg/compare_interfaces.f90 b/gcc/testsuite/gfortran.dg/compare_interfaces.f90
new file mode 100644
index 0000000..cb2cbb7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/compare_interfaces.f90
@@ -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 }
diff --git a/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f90 b/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f90
new file mode 100644
index 0000000..4c50be4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f90
@@ -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
+
diff --git a/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f90 b/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f90
new file mode 100644
index 0000000..1d5bc6c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f90
@@ -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 }
+
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90
index cb98042..259ed1b 100644
--- a/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90
+++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90
@@ -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")
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90
index 0a1d449..db4fc3c 100644
--- a/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90
+++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90
@@ -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" }
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90
index 7073b89..7995c36 100644
--- a/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90
+++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90
@@ -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" }
generated by cgit v1.1 at 2025-05-28 19:45:05 +0000