From patchwork Mon Nov 15 18:41:22 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 71267 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 ED357B7104 for ; Tue, 16 Nov 2010 05:42:08 +1100 (EST) Received: (qmail 4902 invoked by alias); 15 Nov 2010 18:42:05 -0000 Received: (qmail 4883 invoked by uid 22791); 15 Nov 2010 18:42:02 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_MV X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 15 Nov 2010 18:41:26 +0000 Received: from [192.168.178.22] (port-92-204-76-125.dynamic.qsc.de [92.204.76.125]) by mx02.qsc.de (Postfix) with ESMTP id C240A1E9AA; Mon, 15 Nov 2010 19:41:23 +0100 (CET) Message-ID: <4CE17ED2.8000705@net-b.de> Date: Mon, 15 Nov 2010 19:41:22 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.9.2.12) Gecko/20101026 SUSE/3.1.6 Thunderbird/3.1.6 MIME-Version: 1.0 To: gcc patches , gfortran Subject: Re: [Patch, Fortran] PR46484: Function-expressions are not variables References: <4CE162A5.2060408@net-b.de> In-Reply-To: <4CE162A5.2060408@net-b.de> 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 On 11/15/2010 05:41 PM, Tobias Burnus wrote: > The following patch is kind of obvious - at least for Fortran > 90/95/2003: A function call is not a variable!* While the old patch is OK, it does not sufficiently distinguish between function names and function results. With the old patch, all "allocated(f)" are accepted but only those where "f" is also a the result variable should be accepted. (Thanks to Steve for pointing out that there might be an issue with result variables.) The attached patch fixes this. The check whether the usage is valid or not is extremely lengthy. One reason is that there is only a single gfc_symbol for both the valid and invalid case. Thus, looking at e->symtree->n.sym->* does not help. Build on x86-64-linux - and currently regtesting. OK for the trunk? Tobias 2010-11-15 Tobias Burnus PR fortran/46484 * check.c (variable_check): Don't treat functions calls as variables; optionally accept function themselves. (gfc_check_all_any, gfc_check_loc, gfc_check_move_alloc, gfc_check_null, gfc_check_present, gfc_check_cpu_time, gfc_check_date_and_time, gfc_check_mvbits, gfc_check_random_number, gfc_check_random_seed, gfc_check_system_clock, gfc_check_dtime_etime, gfc_check_dtime_etime_sub, gfc_check_itime_idate,gfc_check_ltime_gmtime): Update call. 2010-11-15 Tobias Burnus PR fortran/46484 * gfortran.dg/allocatable_scalar_11.f90: New. * gfortran.dg/allocatable_scalar_5.f90: Make test case standard conform. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 51ea877..f22a8db 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -478,7 +478,7 @@ kind_value_check (gfc_expr *e, int n, int k) /* Make sure an expression is a variable. */ static gfc_try -variable_check (gfc_expr *e, int n) +variable_check (gfc_expr *e, int n, bool allow_proc) { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.intent == INTENT_IN @@ -491,10 +491,15 @@ variable_check (gfc_expr *e, int n) return FAILURE; } - if ((e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.flavor != FL_PARAMETER) - || (e->expr_type == EXPR_FUNCTION - && e->symtree->n.sym->result == e->symtree->n.sym)) + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.flavor != FL_PARAMETER + && (allow_proc + || !e->symtree->n.sym->attr.function + || (e->symtree->n.sym == e->symtree->n.sym->result + && (e->symtree->n.sym == gfc_current_ns->proc_name + || (gfc_current_ns->parent + && e->symtree->n.sym + == gfc_current_ns->parent->proc_name))))) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable", @@ -762,7 +767,7 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) gfc_try gfc_check_allocated (gfc_expr *array) { - if (variable_check (array, 0) == FAILURE) + if (variable_check (array, 0, false) == FAILURE) return FAILURE; if (allocatable_check (array, 0) == FAILURE) return FAILURE; @@ -2041,7 +2046,7 @@ gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) gfc_try gfc_check_loc (gfc_expr *expr) { - return variable_check (expr, 0); + return variable_check (expr, 0, true); } @@ -2516,12 +2521,12 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) gfc_try gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) { - if (variable_check (from, 0) == FAILURE) + if (variable_check (from, 0, false) == FAILURE) return FAILURE; if (allocatable_check (from, 0) == FAILURE) return FAILURE; - if (variable_check (to, 1) == FAILURE) + if (variable_check (to, 1, false) == FAILURE) return FAILURE; if (allocatable_check (to, 1) == FAILURE) return FAILURE; @@ -2598,7 +2603,7 @@ gfc_check_null (gfc_expr *mold) if (mold == NULL) return SUCCESS; - if (variable_check (mold, 0) == FAILURE) + if (variable_check (mold, 0, true) == FAILURE) return FAILURE; attr = gfc_variable_attr (mold, NULL); @@ -2729,7 +2734,7 @@ gfc_check_present (gfc_expr *a) { gfc_symbol *sym; - if (variable_check (a, 0) == FAILURE) + if (variable_check (a, 0, true) == FAILURE) return FAILURE; sym = a->symtree->n.sym; @@ -3914,7 +3919,7 @@ gfc_check_cpu_time (gfc_expr *time) if (type_check (time, 0, BT_REAL) == FAILURE) return FAILURE; - if (variable_check (time, 0) == FAILURE) + if (variable_check (time, 0, false) == FAILURE) return FAILURE; return SUCCESS; @@ -3933,7 +3938,7 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, return FAILURE; if (scalar_check (date, 0) == FAILURE) return FAILURE; - if (variable_check (date, 0) == FAILURE) + if (variable_check (date, 0, false) == FAILURE) return FAILURE; } @@ -3945,7 +3950,7 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, return FAILURE; if (scalar_check (time, 1) == FAILURE) return FAILURE; - if (variable_check (time, 1) == FAILURE) + if (variable_check (time, 1, false) == FAILURE) return FAILURE; } @@ -3957,7 +3962,7 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, return FAILURE; if (scalar_check (zone, 2) == FAILURE) return FAILURE; - if (variable_check (zone, 2) == FAILURE) + if (variable_check (zone, 2, false) == FAILURE) return FAILURE; } @@ -3969,7 +3974,7 @@ gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, return FAILURE; if (rank_check (values, 3, 1) == FAILURE) return FAILURE; - if (variable_check (values, 3) == FAILURE) + if (variable_check (values, 3, false) == FAILURE) return FAILURE; } @@ -3993,7 +3998,7 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, if (same_type_check (from, 0, to, 3) == FAILURE) return FAILURE; - if (variable_check (to, 3) == FAILURE) + if (variable_check (to, 3, false) == FAILURE) return FAILURE; if (type_check (topos, 4, BT_INTEGER) == FAILURE) @@ -4025,7 +4030,7 @@ gfc_check_random_number (gfc_expr *harvest) if (type_check (harvest, 0, BT_REAL) == FAILURE) return FAILURE; - if (variable_check (harvest, 0) == FAILURE) + if (variable_check (harvest, 0, false) == FAILURE) return FAILURE; return SUCCESS; @@ -4058,7 +4063,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) if (type_check (size, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (size, 0) == FAILURE) + if (variable_check (size, 0, false) == FAILURE) return FAILURE; if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE) @@ -4112,7 +4117,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) if (type_check (get, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (get, 2) == FAILURE) + if (variable_check (get, 2, false) == FAILURE) return FAILURE; if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE) @@ -4165,7 +4170,7 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, if (type_check (count, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (count, 0) == FAILURE) + if (variable_check (count, 0, false) == FAILURE) return FAILURE; } @@ -4177,7 +4182,7 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, if (type_check (count_rate, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (count_rate, 1) == FAILURE) + if (variable_check (count_rate, 1, false) == FAILURE) return FAILURE; if (count != NULL @@ -4194,7 +4199,7 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, if (type_check (count_max, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (variable_check (count_max, 2) == FAILURE) + if (variable_check (count_max, 2, false) == FAILURE) return FAILURE; if (count != NULL @@ -4317,7 +4322,7 @@ gfc_check_dtime_etime (gfc_expr *x) if (rank_check (x, 0, 1) == FAILURE) return FAILURE; - if (variable_check (x, 0) == FAILURE) + if (variable_check (x, 0, false) == FAILURE) return FAILURE; if (type_check (x, 0, BT_REAL) == FAILURE) @@ -4339,7 +4344,7 @@ gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) if (rank_check (values, 0, 1) == FAILURE) return FAILURE; - if (variable_check (values, 0) == FAILURE) + if (variable_check (values, 0, false) == FAILURE) return FAILURE; if (type_check (values, 0, BT_REAL) == FAILURE) @@ -4529,7 +4534,7 @@ gfc_check_itime_idate (gfc_expr *values) if (rank_check (values, 0, 1) == FAILURE) return FAILURE; - if (variable_check (values, 0) == FAILURE) + if (variable_check (values, 0, false) == FAILURE) return FAILURE; if (type_check (values, 0, BT_INTEGER) == FAILURE) @@ -4560,7 +4565,7 @@ gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) if (rank_check (values, 1, 1) == FAILURE) return FAILURE; - if (variable_check (values, 1) == FAILURE) + if (variable_check (values, 1, false) == FAILURE) return FAILURE; if (type_check (values, 1, BT_INTEGER) == FAILURE) diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_11.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_11.f90 new file mode 100644 index 0000000..7f4d64d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_11.f90 @@ -0,0 +1,28 @@ +! { dg-compile } +! +! PR fortran/46484 +! + +function g() + implicit none + integer, allocatable :: g + call int() + print *, loc(g) ! OK +contains + subroutine int() + print *, loc(g) ! OK + print *, allocated(g) ! OK + end subroutine int +end function + +implicit none +integer, allocatable :: x +print *, allocated(f) ! { dg-error "must be a variable" } +print *, loc(f) ! OK +contains +function f() + integer, allocatable :: f + print *, loc(f) ! OK + print *, allocated(f) ! OK +end function +end diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90 index cee95a1..efa40e9 100644 --- a/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90 +++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90 @@ -1,7 +1,7 @@ ! { dg-do run } ! { dg-options "-Wall -pedantic" } ! -! PR fortran/41872 +! PR fortran/41872; updated due to PR fortran/46484 ! ! More tests for allocatable scalars ! @@ -11,8 +11,6 @@ program test integer :: b if (allocated (a)) call abort () - if (allocated (func (.false.))) call abort () - if (.not.allocated (func (.true.))) call abort () b = 7 b = func(.true.) if (b /= 5332) call abort () @@ -28,7 +26,6 @@ program test call intout2 (a) if (allocated (a)) call abort () - if (allocated (func2 ())) call abort () contains function func (alloc) @@ -41,10 +38,6 @@ contains end if end function func - function func2 () - integer, allocatable :: func2 - end function func2 - subroutine intout (dum, alloc) implicit none integer, allocatable,intent(out) :: dum