+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
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;
{
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;
}
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
"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;
}
}
"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;
}
"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;
}
{
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;
}
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;
}
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;
}
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;
}
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 *);
|| !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))
"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;
}
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;
}
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 */
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)
/* 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
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 */
}
static int flag = 0;
char *buffer;
gfc_typespec *ts1;
+ gfc_charlen_t length = 0;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
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");
}
+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. */
}
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:
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:
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:
}
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;
}
sprintf (msg, _("Operand of .not. operator at %%L is %s"),
- gfc_typename (&op1->ts));
+ gfc_typename (op1));
goto bad_op;
case INTRINSIC_GT:
msg = "Inequality comparison for %s at %L";
gfc_warning (OPT_Wcompare_reals, msg,
- gfc_typename (&op1->ts), &op1->where);
+ gfc_typename (op1), &op1->where);
}
}
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;
}
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;
}
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;
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
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
+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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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 }
+
--- /dev/null
+! { 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 }
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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 }
+
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")
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" }
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" }
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" }
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" }
projects / platform / upstream / gcc.git / commitdiff