From patchwork Thu Sep 19 12:59:22 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mark Eggleston X-Patchwork-Id: 1164580 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-509265-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=fail (p=none dis=none) header.from=codethink.co.uk Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="ga80J/RY"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 46Yxl86y9Wz9s00 for ; Thu, 19 Sep 2019 22:59:47 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=TtyMRf9wFy4OM6Vj9kdmyWc9fE/Dxqa6phXvxnAD3by+py2d0+ a7KK6/AWZQmViChlraQqqxGCph14tKQsSvAjfPiVo4gSDcBVOfQlCCo80XGuWRNc LO7YbODz6SBDFIFgWz7wvJ1VTTjC+wCJ0r/xVFSsyGQTPZuAwRZDt4GRo= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=lqmI0taCct7mLZZQ+2CueLiqb7M=; b=ga80J/RYUMeyf+ioHqnV 0fGRDmfQ14RwKXKmfQx3mTzXj0WoKPFhT4Ec55j1adXvClIj22MdNu930KbhwQk4 w4eWlVtsBx5BDJpzcOXtVgzQsYBYdbdmU6Eij55DbpesvCNIURmnqEOszJUnw6bS 2KsGwuqjFSMO41U/o/+rlOU= Received: (qmail 15543 invoked by alias); 19 Sep 2019 12:59:33 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 15527 invoked by uid 89); 19 Sep 2019 12:59:33 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-19.7 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_COUK, KAM_SHORT, RCVD_IN_DNSWL_NONE, SPF_HELO_PASS, SPF_PASS autolearn=ham version=3.3.1 spammy=concerning, H*F:D*co.uk, H*F:D*uk, valueopop X-HELO: imap1.codethink.co.uk Received: from imap1.codethink.co.uk (HELO imap1.codethink.co.uk) (176.9.8.82) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 19 Sep 2019 12:59:28 +0000 Received: from [167.98.27.226] (helo=[10.35.4.88]) by imap1.codethink.co.uk with esmtpsa (Exim 4.84_2 #1 (Debian)) id 1iAw1r-0001eq-6x; Thu, 19 Sep 2019 13:59:23 +0100 To: gcc-patches , fortran , Janne Blomqvist , Steve Kargl From: Mark Eggleston Subject: [PATCH, Fortran] Character type names in errors and warnings - new version for review Message-ID: <3c0d1acd-3954-e44f-6980-cd76f11f7b49@codethink.co.uk> Date: Thu, 19 Sep 2019 13:59:22 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101 Thunderbird/60.8.0 MIME-Version: 1.0 Original thread: https://gcc.gnu.org/ml/fortran/2019-09/msg00024.html The original patch introduced a new field in gfc_typespec called length to be used only for character literals. At the time I felt that this was a bit of kludge.  As a results of comments from Janne Blomqvist I investigated whether the existing mechanism for character length in gfc_typespec could be used for character literals. This turn out to be impractical. The character length for literals is already held in the gfc_expr structure for character constants. I've added a new version of gfc_typename that accepts gfc_expr * instead of gfc_typespec. Where character types are possible the gfc_expr * version is now used instead of the gfc_typespec * version. I've implemented Janne's suggestions. I think this is a better solution. Please review. Tested on x86_64 (built with bootstrap). ChangeLogs gcc/fortran     Mark Eggleston      * 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). gcc/testsuite     Mark Eggleston     * 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". From c9b86acc7c3a6c1e684231af95d2b6b5c562379b Mon Sep 17 00:00:00 2001 From: Mark Eggleston Date: Fri, 30 Aug 2019 11:08:26 +0100 Subject: [PATCH] Character typenames in errors and warnings 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) --- gcc/fortran/array.c | 2 +- gcc/fortran/check.c | 10 +-- gcc/fortran/decl.c | 2 +- gcc/fortran/expr.c | 8 +-- gcc/fortran/gfortran.h | 2 + gcc/fortran/interface.c | 11 ++-- gcc/fortran/intrinsic.c | 27 ++++---- gcc/fortran/misc.c | 71 +++++++++++++++++++- gcc/fortran/resolve.c | 32 ++++----- gcc/testsuite/gfortran.dg/bad_operands.f90 | 10 +++ gcc/testsuite/gfortran.dg/character_mismatch.f90 | 76 ++++++++++++++++++++++ gcc/testsuite/gfortran.dg/compare_interfaces.f90 | 73 +++++++++++++++++++++ .../gfortran.dg/hollerith_to_char_parameter_1.f90 | 11 ++++ .../gfortran.dg/hollerith_to_char_parameter_2.f90 | 12 ++++ .../gfortran.dg/widechar_intrinsics_1.f90 | 12 ++-- .../gfortran.dg/widechar_intrinsics_2.f90 | 10 +-- .../gfortran.dg/widechar_intrinsics_3.f90 | 4 +- 17 files changed, 315 insertions(+), 58 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/bad_operands.f90 create mode 100644 gcc/testsuite/gfortran.dg/character_mismatch.f90 create mode 100644 gcc/testsuite/gfortran.dg/compare_interfaces.f90 create mode 100644 gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f90 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index ba8a81655ed..3a504ebfea8 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 a04f9fbb2a9..d41da602e9a 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 278882d9855..9ad7c87bcd8 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 5d3480eb4a5..9f638fe4dc3 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 6f7717d1134..ef444b31afd 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2883,7 +2883,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 08e4f063a67..3313e729db9 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 764e3500926..ac5af10a775 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 eed203dee02..97df9eea94e 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 f1de7dd76c6..0add36f50bf 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3965,7 +3965,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: @@ -3987,8 +3987,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: @@ -4002,7 +4002,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: @@ -4044,8 +4044,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; @@ -4067,7 +4067,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: @@ -4153,7 +4153,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); } } @@ -4169,8 +4169,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; @@ -4188,12 +4188,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; } @@ -8490,7 +8490,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; @@ -8519,7 +8519,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 @@ -8527,7 +8527,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/gfortran.dg/bad_operands.f90 b/gcc/testsuite/gfortran.dg/bad_operands.f90 new file mode 100644 index 00000000000..e82a07fdbd3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bad_operands.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston + +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 00000000000..e1619467ccc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/character_mismatch.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston + +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 00000000000..cb2cbb759a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/compare_interfaces.f90 @@ -0,0 +1,73 @@ +! { dg-do compile } +! +! Contributed by Mark Eggleston + +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 00000000000..4c50be4acbb --- /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 + +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 00000000000..1d5bc6cd7e3 --- /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 + +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 cb9804296dd..259ed1b783e 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 0a1d449b605..db4fc3c1f4e 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 7073b893bb3..7995c3693f9 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" } -- 2.11.0