From patchwork Thu Dec 23 08:33:45 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 76481 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 83BF7B70D5 for ; Thu, 23 Dec 2010 19:33:58 +1100 (EST) Received: (qmail 8193 invoked by alias); 23 Dec 2010 08:33:56 -0000 Received: (qmail 8173 invoked by uid 22791); 23 Dec 2010 08:33:55 -0000 X-SWARE-Spam-Status: No, hits=1.3 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, RCVD_IN_JMF_BL, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from cc-smtpout1.netcologne.de (HELO cc-smtpout1.netcologne.de) (89.1.8.211) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 23 Dec 2010 08:33:50 +0000 Received: from cc-smtpin2.netcologne.de (cc-smtpin2.netcologne.de [89.1.8.202]) by cc-smtpout1.netcologne.de (Postfix) with ESMTP id 5A2301249E; Thu, 23 Dec 2010 09:33:47 +0100 (CET) Received: from [192.168.0.197] (xdsl-78-35-155-84.netcologne.de [78.35.155.84]) by cc-smtpin2.netcologne.de (Postfix) with ESMTPA id 3A0C111E5B; Thu, 23 Dec 2010 09:33:46 +0100 (CET) Subject: [patch, fortran] PR 31821 - substring checking on pointer assignment From: Thomas Koenig To: fortran@gcc.gnu.org Cc: gcc-patches@gcc.gnu.org Date: Thu, 23 Dec 2010 09:33:45 +0100 Message-ID: <1293093225.6414.3.camel@linux-fd1f.site> Mime-Version: 1.0 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 Hello world, the following patch checks substring lengths for pointer assignments during compile time. Regression-tested. OK for trunk? Merry christmas and a happy new year, everybody! Thomas 2010-12-23 Thomas Koenig PR fortran/31821 * check.c (gfc_var_strlen): New function, also including substring references. (gfc_check_same_strlen): Use gfc_var_strlen. 2010-12-23 Thomas Koenig PR fortran/31821 * gfortran.dg/char_pointer_assign_6.f90: New test. Index: check.c =================================================================== --- check.c (Revision 167770) +++ check.c (Arbeitskopie) @@ -635,40 +635,69 @@ return ret; } +/* Calculate the length of a character variable, including substrings. + Strip away parentheses if necessary. Return -1 if no length could + be determined. */ +static long +gfc_var_strlen (const gfc_expr *a) +{ + gfc_ref *ra; + + while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES) + a = a->value.op.op1; + + for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next) + ; + + if (ra) + { + long start_a, end_a; + + if (ra->u.ss.start->expr_type == EXPR_CONSTANT + && ra->u.ss.end->expr_type == EXPR_CONSTANT) + { + start_a = mpz_get_si (ra->u.ss.start->value.integer); + end_a = mpz_get_si (ra->u.ss.end->value.integer); + return end_a - start_a + 1; + } + else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0) + return 1; + else + return -1; + } + + if (a->ts.u.cl && a->ts.u.cl->length + && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) + return mpz_get_si (a->ts.u.cl->length->value.integer); + else if (a->expr_type == EXPR_CONSTANT + && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) + return a->value.character.length; + else + return -1; + +} + /* Check whether two character expressions have the same length; - returns SUCCESS if they have or if the length cannot be determined. */ + returns SUCCESS if they have or if the length cannot be determined, + otherwise return FAILURE and raise a gfc_error. */ gfc_try gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) { long len_a, len_b; - len_a = len_b = -1; - if (a->ts.u.cl && a->ts.u.cl->length - && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) - len_a = mpz_get_si (a->ts.u.cl->length->value.integer); - else if (a->expr_type == EXPR_CONSTANT - && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) - len_a = a->value.character.length; - else + len_a = gfc_var_strlen(a); + len_b = gfc_var_strlen(b); + + if (len_a == -1 || len_b == -1 || len_a == len_b) return SUCCESS; - - if (b->ts.u.cl && b->ts.u.cl->length - && b->ts.u.cl->length->expr_type == EXPR_CONSTANT) - len_b = mpz_get_si (b->ts.u.cl->length->value.integer); - else if (b->expr_type == EXPR_CONSTANT - && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL)) - len_b = b->value.character.length; else - return SUCCESS; - - if (len_a == len_b) - return SUCCESS; - - gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", - len_a, len_b, name, &a->where); - return FAILURE; + { + gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", + len_a, len_b, name, &a->where); + return FAILURE; + } }