re PR fortran/20863 ([4.2 only] Pointer problems in PURE procedures)
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
parent
80dcd3aa9b
commit
d2088bb6d4
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
||||
Loading…
Reference in New Issue