OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/20863 ([4.2 only] Pointer problems in PURE procedures)

Browse Source 
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
This commit is contained in:
Paul Thomas 2007-06-18 23:04:28 +00:00
parent 80dcd3aa9b
commit d2088bb6d4
7 changed files with 164 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
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

11
gcc/fortran/data.c
View File

@ -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);

32
gcc/fortran/resolve.c
View File

@ -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;
}

12
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,15 @@
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

8
gcc/testsuite/gfortran.dg/data_initialized_2.f90 Normal file
View File

@ -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 <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

30
gcc/testsuite/gfortran.dg/equiv_7.f90
View File

@ -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

70
gcc/testsuite/gfortran.dg/impure_assignment_2.f90 Normal file
View File

@ -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 <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" } }