From d2088bb6d4b1479b20cda33566fe9b2a5d93ef70 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 18 Jun 2007 23:04:28 +0000 Subject: [PATCH] re PR fortran/20863 ([4.2 only] Pointer problems in PURE procedures) 2007-06-19 Paul Thomas PR fortran/20863 PR fortran/20082 * resolve.c (resolve_code): Use gfc_impure_variable as a condition for rejecting derived types with pointers, in pure procedures. (gfc_impure_variable): Add test for dummy arguments of pure procedures; any for functions and INTENT_IN for subroutines. PR fortran/32236 * data.c (gfc_assign_data_value): Change the ICE on an array reference initializer not being an array into an error and clear init to prevent a repetition of the error. 2007-06-19 Paul Thomas PR fortran/20863 PR fortran/20082 * gfortran.dg/impure_assignment_2.f90 : New test. PR fortran/32236 * gfortran.dg/data_initialized_2.f90 : New test. * gfortran.dg/equiv_7.f90 : Test for endianess and call the appropriate version of 'dmach'. From-SVN: r125831 --- gcc/fortran/ChangeLog | 15 ++++ gcc/fortran/data.c | 11 ++- gcc/fortran/resolve.c | 32 +++++++-- gcc/testsuite/ChangeLog | 12 ++++ .../gfortran.dg/data_initialized_2.f90 | 8 +++ gcc/testsuite/gfortran.dg/equiv_7.f90 | 30 ++++++-- .../gfortran.dg/impure_assignment_2.f90 | 70 +++++++++++++++++++ 7 files changed, 164 insertions(+), 14 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/data_initialized_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/impure_assignment_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7528c11b691..74b8103d61e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2007-06-19 Paul Thomas + + PR fortran/20863 + PR fortran/20082 + * resolve.c (resolve_code): Use gfc_impure_variable as a + condition for rejecting derived types with pointers, in pure + procedures. + (gfc_impure_variable): Add test for dummy arguments of pure + procedures; any for functions and INTENT_IN for subroutines. + + PR fortran/32236 + * data.c (gfc_assign_data_value): Change the ICE on an array + reference initializer not being an array into an error and + clear init to prevent a repetition of the error. + 2007-06-17 Janne Blomqvist * gfortran.texi: Add documentation for GFORTRAN_UNBUFFERED_n diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 75e4241e059..35213a8fdb3 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -288,6 +288,15 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) switch (ref->type) { case REF_ARRAY: + if (init && expr->expr_type != EXPR_ARRAY) + { + gfc_error ("'%s' at %L already is initialized at %L", + lvalue->symtree->n.sym->name, &lvalue->where, + &init->where); + gfc_free_expr (init); + init = NULL; + } + if (init == NULL) { /* The element typespec will be the same as the array @@ -297,8 +306,6 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) expr->expr_type = EXPR_ARRAY; expr->rank = ref->u.ar.as->rank; } - else - gcc_assert (expr->expr_type == EXPR_ARRAY); if (ref->u.ar.type == AR_ELEMENT) get_array_index (&ref->u.ar, &offset); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 99797aa7ec3..cbf4f7cea29 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5266,17 +5266,20 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; } - if (code->expr2->ts.type == BT_DERIVED - && derived_pointer (code->expr2->ts.derived)) + if (code->expr->ts.type == BT_DERIVED + && code->expr->expr_type == EXPR_VARIABLE + && derived_pointer (code->expr->ts.derived) + && gfc_impure_variable (code->expr2->symtree->n.sym)) { - gfc_error ("Right side of assignment at %L is a derived " - "type containing a POINTER in a PURE procedure", + gfc_error ("The impure variable at %L is assigned to " + "a derived type variable with a POINTER " + "component in a PURE procedure (12.6)", &code->expr2->where); break; } } - gfc_check_assign (code->expr, code->expr2, 1); + gfc_check_assign (code->expr, code->expr2, 1); break; case EXEC_LABEL_ASSIGN: @@ -6800,21 +6803,36 @@ resolve_data (gfc_data * d) } +/* 12.6 Constraint: In a pure subprogram any variable which is in common or + accessed by host or use association, is a dummy argument to a pure function, + is a dummy argument with INTENT (IN) to a pure subroutine, or an object that + is storage associated with any such variable, shall not be used in the + following contexts: (clients of this function). */ + /* Determines if a variable is not 'pure', ie not assignable within a pure procedure. Returns zero if assignment is OK, nonzero if there is a problem. */ - int gfc_impure_variable (gfc_symbol *sym) { + gfc_symbol *proc; + if (sym->attr.use_assoc || sym->attr.in_common) return 1; if (sym->ns != gfc_current_ns) return !sym->attr.function; - /* TODO: Check storage association through EQUIVALENCE statements */ + proc = sym->ns->proc_name; + if (sym->attr.dummy && gfc_pure (proc) + && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN) + || + proc->attr.function)) + return 1; + /* TODO: Sort out what can be storage associated, if anything, and include + it here. In principle equivalences should be scanned but it does not + seem to be possible to storage associate an impure variable this way. */ return 0; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0d626bb3709..58380472215 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2007-06-19 Paul Thomas + + PR fortran/20863 + PR fortran/20082 + * gfortran.dg/impure_assignment_2.f90 : New test. + + PR fortran/32236 + * gfortran.dg/data_initialized_2.f90 : New test. + + * gfortran.dg/equiv_7.f90 : Test for endianess and call the + appropriate version of 'dmach'. + 2007-06-18 Uros Bizjak PR target/32389 diff --git a/gcc/testsuite/gfortran.dg/data_initialized_2.f90 b/gcc/testsuite/gfortran.dg/data_initialized_2.f90 new file mode 100644 index 00000000000..c6331cd0c4f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/data_initialized_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! Tests the fix for PR32236, in which the error below manifested itself +! as an ICE. +! Contributed by Bob Arduini + real :: x(2) = 1.0 ! { dg-error "already is initialized" } + data x /1.0, 2.0/ ! { dg-error "already is initialized" } + print *, x +end diff --git a/gcc/testsuite/gfortran.dg/equiv_7.f90 b/gcc/testsuite/gfortran.dg/equiv_7.f90 index 51beba72787..925f40ac1b4 100644 --- a/gcc/testsuite/gfortran.dg/equiv_7.f90 +++ b/gcc/testsuite/gfortran.dg/equiv_7.f90 @@ -13,16 +13,26 @@ block data data cb /99/ end block data + integer(4), parameter :: abcd = ichar ("a") + 256_4 * (ichar("b") + 256_4 * & + (ichar ("c") + 256_4 * ichar ("d"))) + logical(4), parameter :: bigendian = transfer (abcd, "wxyz") .eq. "abcd" + call int4_int4 call real4_real4 call complex_real call check_block_data call derived_types ! Thanks to Tobias Burnus for this:) ! -! This came up in PR29786 comment #9 +! This came up in PR29786 comment #9 - Note the need to treat endianess +! Thanks Dominique d'Humieres:) ! - if (d1mach (1) .ne. transfer ((/0_4, 1048576_4/), 1d0)) call abort () - if (d1mach (2) .ne. transfer ((/-1_4,2146435071_4/), 1d0)) call abort () + if (bigendian) then + if (d1mach_little (1) .ne. transfer ((/0_4, 1048576_4/), 1d0)) call abort () + if (d1mach_little (2) .ne. transfer ((/-1_4,2146435071_4/), 1d0)) call abort () + else + if (d1mach_big (1) .ne. transfer ((/1048576_4, 0_4/), 1d0)) call abort () + if (d1mach_big (2) .ne. transfer ((/2146435071_4,-1_4/), 1d0)) call abort () + end if ! contains subroutine int4_int4 @@ -59,7 +69,7 @@ contains integer(4) ca if (any (ca .ne. (/42, 43, 99, 44/))) call abort () end subroutine check_block_data - function d1mach(i) + function d1mach_little(i) result(d1mach) implicit none double precision d1mach,dmach(5) integer i,large(4),small(4) @@ -68,7 +78,17 @@ contains data small(1),small(2) / 0, 1048576/ data large(1),large(2) /-1,2146435071/ d1mach = dmach(i) - end function d1mach + end function d1mach_little + function d1mach_big(i) result(d1mach) + implicit none + double precision d1mach,dmach(5) + integer i,large(4),small(4) + equivalence ( dmach(1), small(1) ) + equivalence ( dmach(2), large(1) ) + data small(1),small(2) /1048576, 0/ + data large(1),large(2) /2146435071,-1/ + d1mach = dmach(i) + end function d1mach_big subroutine derived_types TYPE T1 sequence diff --git a/gcc/testsuite/gfortran.dg/impure_assignment_2.f90 b/gcc/testsuite/gfortran.dg/impure_assignment_2.f90 new file mode 100644 index 00000000000..3b212c19897 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/impure_assignment_2.f90 @@ -0,0 +1,70 @@ +! { dg-do compile } +! Tests the fix for PR20863 and PR20882, which were concerned with incorrect +! application of constraints associated with "impure" variables in PURE +! procedures. +! +! resolve.c (gfc_impure_variable) detects the following: +! 12.6 Constraint: In a pure subprogram any variable which is in common or +! accessed by host or use association, is a dummy argument to a pure function, +! is a dummy argument with INTENT (IN) to a pure subroutine, or an object that +! is storage associated with any such variable, shall not be used in the +! following contexts: (clients of this function). */ +! +! Contributed by Joost VandeVondele +! +MODULE pr20863 + TYPE node_type + TYPE(node_type), POINTER :: next=>null() + END TYPE +CONTAINS +! Original bug - pointer assignments to "impure" derived type with +! pointer component. + PURE FUNCTION give_next1(node) + TYPE(node_type), POINTER :: node + TYPE(node_type), POINTER :: give_next + give_next => node%next ! { dg-error "Bad target" } + node%next => give_next ! { dg-error "Bad pointer object" } + END FUNCTION +! Comment #2 + PURE integer FUNCTION give_next2(i) + TYPE node_type + sequence + TYPE(node_type), POINTER :: next + END TYPE + TYPE(node_type), POINTER :: node + TYPE(node_type), target :: t + integer, intent(in) :: i + node%next = t ! This is OK + give_next2 = i + END FUNCTION + PURE FUNCTION give_next3(node) + TYPE(node_type), intent(in) :: node + TYPE(node_type) :: give_next + give_next = node ! { dg-error "impure variable" } + END FUNCTION +END MODULE pr20863 + +MODULE pr20882 + TYPE T1 + INTEGER :: I + END TYPE T1 + TYPE(T1), POINTER :: B +CONTAINS + PURE FUNCTION TST(A) RESULT(RES) + TYPE(T1), INTENT(IN), TARGET :: A + TYPE(T1), POINTER :: RES + RES => A ! { dg-error "Bad target" } + RES => B ! { dg-error "Bad target" } + B => RES ! { dg-error "Bad pointer object" } + END FUNCTION + PURE FUNCTION TST2(A) RESULT(RES) + TYPE(T1), INTENT(IN), TARGET :: A + TYPE(T1), POINTER :: RES + allocate (RES) + RES = A + B = RES ! { dg-error "Cannot assign" } + RES = B + END FUNCTION +END MODULE pr20882 +! { dg-final { cleanup-modules "pr20863 pr20882" } } +