2007-06-19 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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
+2007-06-19 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <jb@gcc.gnu.org>
* gfortran.texi: Add documentation for GFORTRAN_UNBUFFERED_n
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
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);
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:
}
+/* 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;
}
+2007-06-19 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <ubizjak@gmail.com>
PR target/32389
--- /dev/null
+! { dg-do compile }
+! Tests the fix for PR32236, in which the error below manifested itself
+! as an ICE.
+! Contributed by Bob Arduini <r.f.arduini@larc.nasa.gov>
+ real :: x(2) = 1.0 ! { dg-error "already is initialized" }
+ data x /1.0, 2.0/ ! { dg-error "already is initialized" }
+ print *, x
+end
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
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)
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
--- /dev/null
+! { 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 <jv244@cam.ac.uk>
+!
+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" } }
+
projects / thirdparty / gcc.git / commitdiff
