procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/26822 (Scalarization of non-elemental intrinsic: __logical_4_l4)

Browse source 
2006-04-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26822
	* intrinsic.c (add_functions): Mark LOGICAL as elemental.

	PR fortran/26787
	* expr.c (gfc_check_assign): Extend scope of error to include
	assignments to a procedure in the main program or, from a
	module or internal procedure that is not that represented by
	the lhs symbol. Use VARIABLE rather than l-value in message.

	PR fortran/27096
	* trans-array.c (gfc_trans_deferred_array): If the backend_decl
	is not a descriptor, dereference and then test and use the type.

	PR fortran/25597
	* trans-decl.c (gfc_trans_deferred_vars): Check if an array
	result, is also automatic character length.  If so, process
	the character length.

	PR fortran/18803
	PR fortran/25669
	PR fortran/26834
	* trans_intrinsic.c (gfc_walk_intrinsic_bound): Set
	data.info.dimen for bound intrinsics.
	* trans_array.c (gfc_conv_ss_startstride): Pick out LBOUND and
	UBOUND intrinsics and supply their shape information to the ss
	and the loop.

	PR fortran/27124
	* trans_expr.c (gfc_trans_function_call):  Add a new block, post,
	in to which all the argument post blocks are put.  Add this block
	to se->pre after a byref call or to se->post, otherwise.

2006-04-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26787
	* gfortran.dg/proc_assign_1.f90: New test.
	* gfortran.dg/procedure_lvalue.f90: Change message.
	* gfortran.dg/namelist_4.f90: Add new error.

	PR fortran/27096
	* gfortran.dg/auto_pointer_array_result_1.f90

	PR fortran/27089
	* gfortran.dg/specification_type_resolution_1.f90

	PR fortran/18803
	PR fortran/25669
	PR fortran/26834
	* gfortran.dg/bounds_temporaries_1.f90: New test.

	PR fortran/27124
	* gfortran.dg/array_return_value_1.f90: New test.

From-SVN: r112981
This commit is contained in:
Paul Thomas 2006-04-16 03:45:24 +00:00
parent 7fe25d1a55
commit f5f701ad00
17 changed files with 427 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
gcc/fortran/ChangeLog
View file

@ -1,3 +1,37 @@
2006-04-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/26822
* intrinsic.c (add_functions): Mark LOGICAL as elemental.
PR fortran/26787
* expr.c (gfc_check_assign): Extend scope of error to include
assignments to a procedure in the main program or, from a
module or internal procedure that is not that represented by
the lhs symbol. Use VARIABLE rather than l-value in message.
PR fortran/27096
* trans-array.c (gfc_trans_deferred_array): If the backend_decl
is not a descriptor, dereference and then test and use the type.
PR fortran/25597
* trans-decl.c (gfc_trans_deferred_vars): Check if an array
result, is also automatic character length. If so, process
the character length.
PR fortran/18803
PR fortran/25669
PR fortran/26834
* trans_intrinsic.c (gfc_walk_intrinsic_bound): Set
data.info.dimen for bound intrinsics.
* trans_array.c (gfc_conv_ss_startstride): Pick out LBOUND and
UBOUND intrinsics and supply their shape information to the ss
and the loop.
PR fortran/27124
* trans_expr.c (gfc_trans_function_call): Add a new block, post,
in to which all the argument post blocks are put. Add this block
to se->pre after a byref call or to se->post, otherwise.
2006-04-14 Roger Sayle <roger@eyesopen.com>
* trans-io.c (set_string): Use fold_build2 and build_int_cst instead

46
gcc/fortran/expr.c
View file

@ -1863,13 +1863,49 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
return FAILURE;
}
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
/* 12.5.2.2, Note 12.26: The result variable is very similar to any other
variable local to a function subprogram. Its existence begins when
execution of the function is initiated and ends when execution of the
function is terminated.....
Therefore, the left hand side is no longer a varaiable, when it is:*/
if (sym->attr.flavor == FL_PROCEDURE
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.external)
{
gfc_error ("'%s' in the assignment at %L cannot be an l-value "
"since it is a procedure", sym->name, &lvalue->where);
return FAILURE;
}
bool bad_proc;
bad_proc = false;
/* (i) Use associated; */
if (sym->attr.use_assoc)
bad_proc = true;
/* (ii) The assignement is in the main program; or */
if (gfc_current_ns->proc_name->attr.is_main_program)
bad_proc = true;
/* (iii) A module or internal procedure.... */
if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
|| gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
&& gfc_current_ns->parent
&& (!(gfc_current_ns->parent->proc_name->attr.function
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.is_main_program))
{
/* .... that is not a function.... */
if (!gfc_current_ns->proc_name->attr.function)
bad_proc = true;
/* .... or is not an entry and has a different name. */
if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
bad_proc = true;
}
if (bad_proc)
{
gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
return FAILURE;
}
}
if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
{

2
gcc/fortran/intrinsic.c
View file

@ -1670,7 +1670,7 @@ add_functions (void)
make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
add_sym_2 ("logical", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
add_sym_2 ("logical", 1, 1, BT_LOGICAL, dl, GFC_STD_F95,
gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);

10
gcc/fortran/resolve.c
View file

@ -952,9 +952,17 @@ resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
{
expr->value.function.name = s->name;
expr->value.function.esym = s;
expr->ts = s->ts;
if (s->ts.type != BT_UNKNOWN)
expr->ts = s->ts;
else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
expr->ts = s->result->ts;
if (s->as != NULL)
expr->rank = s->as->rank;
else if (s->result != NULL && s->result->as != NULL)
expr->rank = s->result->as->rank;
return MATCH_YES;
}

32
gcc/fortran/trans-array.c
View file

@ -2393,6 +2393,18 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
loop->dimen = ss->data.info.dimen;
break;
/* As usual, lbound and ubound are exceptions!. */
case GFC_SS_INTRINSIC:
switch (ss->expr->value.function.isym->generic_id)
{
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
loop->dimen = ss->data.info.dimen;
default:
break;
}
default:
break;
}
@ -2418,6 +2430,17 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
gfc_conv_section_startstride (loop, ss, n);
break;
case GFC_SS_INTRINSIC:
switch (ss->expr->value.function.isym->generic_id)
{
/* Fall through to supply start and stride. */
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
break;
default:
continue;
}
case GFC_SS_CONSTRUCTOR:
case GFC_SS_FUNCTION:
for (n = 0; n < ss->data.info.dimen; n++)
@ -4391,7 +4414,14 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
if (!GFC_DESCRIPTOR_TYPE_P (type))
{
/* If the backend_decl is not a descriptor, we must have a pointer
to one. */
descriptor = build_fold_indirect_ref (sym->backend_decl);
type = TREE_TYPE (descriptor);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
}
/* NULLIFY the data pointer. */
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);

6
gcc/fortran/trans-decl.c
View file

@ -2536,6 +2536,12 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
tree result = TREE_VALUE (current_fake_result_decl);
fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
/* An automatic character length, pointer array result. */
if (proc_sym->ts.type == BT_CHARACTER
&& TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
fnbody);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{

10
gcc/fortran/trans-expr.c
View file

@ -1832,6 +1832,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_charlen cl;
gfc_expr *e;
gfc_symbol *fsym;
stmtblock_t post;
arglist = NULL_TREE;
retargs = NULL_TREE;
@ -1861,6 +1862,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
else
info = NULL;
gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
&& sym->ts.cl->length
@ -1970,7 +1972,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_add_interface_mapping (&mapping, fsym, &parmse);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
gfc_add_block_to_block (&post, &parmse.post);
/* Character strings are passed as two parameters, a length and a
pointer. */
@ -2177,6 +2179,12 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
}
}
/* Follow the function call with the argument post block. */
if (byref)
gfc_add_block_to_block (&se->pre, &post);
else
gfc_add_block_to_block (&se->post, &post);
return has_alternate_specifier;
}

1
gcc/fortran/trans-intrinsic.c
View file

@ -3710,6 +3710,7 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
newss->type = GFC_SS_INTRINSIC;
newss->expr = expr;
newss->next = ss;
newss->data.info.dimen = 1;
return newss;
}

22
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,25 @@
2006-04-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/26787
* gfortran.dg/proc_assign_1.f90: New test.
* gfortran.dg/procedure_lvalue.f90: Change message.
* gfortran.dg/namelist_4.f90: Add new error.
PR fortran/25597
PR fortran/27096
* gfortran.dg/auto_pointer_array_result_1.f90
PR fortran/27089
* gfortran.dg/specification_type_resolution_1.f90
PR fortran/18803
PR fortran/25669
PR fortran/26834
* gfortran.dg/bounds_temporaries_1.f90: New test.
PR fortran/27124
* gfortran.dg/array_return_value_1.f90: New test.
2006-04-15 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/25336

24
gcc/testsuite/gfortran.dg/array_return_value_1.f90 Normal file
View file

@ -0,0 +1,24 @@
! { dg-do run }
! Tests the fix for PR27124 in which the unpacking of argument
! temporaries and of array result temporaries occurred in the
! incorrect order.
!
! Test is based on the original example, provided by
! Philippe Schaffnit <P.Schaffnit@access.rwth-aachen.de>
!
PROGRAM Test
INTEGER :: Array(2, 3) = reshape ((/1,4,2,5,3,6/),(/2,3/))
integer :: Brray(2, 3) = 0
Brray(1,:) = Function_Test (Array(1,:))
if (any(reshape (Brray, (/6/)) .ne. (/11, 0, 12, 0, 13, 0/))) call abort ()
Array(1,:) = Function_Test (Array(1,:))
if (any(reshape (Array, (/6/)) .ne. (/11, 4, 12, 5, 13, 6/))) call abort ()
contains
FUNCTION Function_Test (Input)
INTEGER, INTENT(IN) :: Input(1:3)
INTEGER :: Function_Test(1:3)
Function_Test = Input + 10
END FUNCTION Function_Test
END PROGRAM Test

36
gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 Normal file
View file

@ -0,0 +1,36 @@
! { dg-do run }
! Tests the fixes for PR25597 and PR27096.
!
! This test combines the PR testcases.
!
character(10), dimension (2) :: implicit_result
character(10), dimension (2) :: explicit_result
character(10), dimension (2) :: source
source = "abcdefghij"
explicit_result = join_1(source)
if (any (explicit_result .ne. source)) call abort ()
implicit_result = reallocate_hnv (source, size(source, 1), LEN (source))
if (any (implicit_result .ne. source)) call abort ()
contains
! This function would cause an ICE in gfc_trans_deferred_array.
function join_1(self) result(res)
character(len=*), dimension(:) :: self
character(len=len(self)), dimension(:), pointer :: res
allocate (res(2))
res = self
end function
! This function originally ICEd and latterly caused a runtime error.
FUNCTION reallocate_hnv(p, n, LEN)
CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv
character(*), dimension(:) :: p
ALLOCATE (reallocate_hnv(n))
reallocate_hnv = p
END FUNCTION reallocate_hnv
end

36
gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 Normal file
View file

@ -0,0 +1,36 @@
! { dg-do run }
! Tests the fixes for PR25597 and PR27096.
!
! This test combines the PR testcases.
!
character(10), dimension (2) :: implicit_result
character(10), dimension (2) :: explicit_result
character(10), dimension (2) :: source
source = "abcdefghij"
explicit_result = join_1(source)
if (any (explicit_result .ne. source)) call abort ()
implicit_result = reallocate_hnv (source, size(source, 1), LEN (source))
if (any (implicit_result .ne. source)) call abort ()
contains
! This function would cause an ICE in gfc_trans_deferred_array.
function join_1(self) result(res)
character(len=*), dimension(:) :: self
character(len=len(self)), dimension(:), pointer :: res
allocate (res(2))
res = self
end function
! This function originally ICEd and latterly caused a runtime error.
FUNCTION reallocate_hnv(p, n, LEN)
CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv
character(*), dimension(:) :: p
ALLOCATE (reallocate_hnv(n))
reallocate_hnv = p
END FUNCTION reallocate_hnv
end

64
gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 Normal file
View file

@ -0,0 +1,64 @@
! { dg-do compile }
! This tests the fix for PRs 26834, 25669 and 18803, in which
! shape information for the lbound and ubound intrinsics was not
! transferred to the scalarizer. For this reason, an ICE would
! ensue, whenever these functions were used in temporaries.
!
! The tests are lifted from the PRs and some further checks are
! done to make sure that nothing is broken.
!
! This is PR26834
subroutine gfcbug34 ()
implicit none
type t
integer, pointer :: i (:) => NULL ()
end type t
type(t), save :: gf
allocate (gf%i(20))
write(*,*) 'ubound:', ubound (gf% i)
write(*,*) 'lbound:', lbound (gf% i)
end subroutine gfcbug34
! This is PR25669
subroutine foo (a)
real a(*)
call bar (a, LBOUND(a),2)
end subroutine foo
subroutine bar (b, i, j)
real b(i:j)
print *, i, j
print *, b(i:j)
end subroutine bar
! This is PR18003
subroutine io_bug()
integer :: a(10)
print *, ubound(a)
end subroutine io_bug
! This checks that lbound and ubound are OK in temporary
! expressions.
subroutine io_bug_plus()
integer :: a(10, 10), b(2)
print *, ubound(a)*(/1,2/)
print *, (/1,2/)*ubound(a)
end subroutine io_bug_plus
character(4) :: ch(2), ech(2) = (/'ABCD', 'EFGH'/)
real(4) :: a(2)
equivalence (ech,a) ! { dg-warning "default CHARACTER EQUIVALENCE statement" }
integer(1) :: i(8) = (/(j, j = 1,8)/)
! Check that the bugs have gone
call io_bug ()
call io_bug_plus ()
call foo ((/1.0,2.0,3.0/))
call gfcbug34 ()
! Check that we have not broken other intrinsics.
print *, cos ((/1.0,2.0/))
print *, transfer (a, ch)
print *, i(1:4) * transfer (a, i, 4) * 2
end

5
gcc/testsuite/gfortran.dg/namelist_4.f90
View file

@ -28,8 +28,9 @@ program P1
CONTAINS
! This has the additional wrinkle of a reference to the object.
INTEGER FUNCTION F1()
NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }
f2 = 1 ! Used to ICE here
NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }
! Used to ICE here
f2 = 1 ! { dg-error "is not a VALUE" }
F1=1
END FUNCTION
INTEGER FUNCTION F2()

78
gcc/testsuite/gfortran.dg/proc_assign_1.f90 Normal file
View file

@ -0,0 +1,78 @@
! { dg-do compile }
! This tests the patch for PR26787 in which it was found that setting
! the result of one module procedure from within another produced an
! ICE rather than an error.
!
! This is an "elaborated" version of the original testcase from
! Joshua Cogliati <jjcogliati-r1@yahoo.com>
!
function ext1 ()
integer ext1, ext2, arg
ext1 = 1
entry ext2 (arg)
ext2 = arg
contains
subroutine int_1 ()
ext1 = arg * arg ! OK - host associated.
end subroutine int_1
end function ext1
module simple
implicit none
contains
integer function foo ()
foo = 10 ! OK - function result
call foobar ()
contains
subroutine foobar ()
integer z
foo = 20 ! OK - host associated.
end subroutine foobar
end function foo
subroutine bar() ! This was the original bug.
foo = 10 ! { dg-error "is not a VALUE" }
end subroutine bar
integer function oh_no ()
oh_no = 1
foo = 5 ! { dg-error "is not a VALUE" }
end function oh_no
end module simple
module simpler
implicit none
contains
integer function foo_er ()
foo_er = 10 ! OK - function result
end function foo_er
end module simpler
use simpler
real w, stmt_fcn
interface
function ext1 ()
integer ext1
end function ext1
function ext2 (arg)
integer ext2, arg
end function ext2
end interface
stmt_fcn (w) = sin (w)
call x (y ())
x = 10 ! { dg-error "Expected VARIABLE" }
y = 20 ! { dg-error "is not a VALUE" }
foo_er = 8 ! { dg-error "is not a VALUE" }
ext1 = 99 ! { dg-error "is not a VALUE" }
ext2 = 99 ! { dg-error "is not a VALUE" }
stmt_fcn = 1.0 ! { dg-error "Expected VARIABLE" }
w = stmt_fcn (1.0)
contains
subroutine x (i)
integer i
y = i ! { dg-error "is not a VALUE" }
end subroutine x
function y ()
integer y
y = 2 ! OK - function result
end function y
end
! { dg-final { cleanup-modules "simple simpler" } }

2
gcc/testsuite/gfortran.dg/procedure_lvalue.f90
View file

@ -14,7 +14,7 @@ end module t
subroutine r
use t
b = 1. ! { dg-error "l-value since it is a procedure" }
b = 1. ! { dg-error "is not a VALUE" }
y = a(1.)
end subroutine r

31
gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 Normal file
View file

@ -0,0 +1,31 @@
! { dg-do compile }
! Test of the fix of PR27089, where gfortran was unable to resolve the
! type of n_elements_uncommon_with_ in the specification expression on
! line 21.
!
! Test extracted from vec{int}.F90 of tonto.
!
module test
public n_elements_uncommon_with_
interface n_elements_uncommon_with_
module procedure n_elements_uncommon_with
end interface
contains
pure function n_elements_uncommon_with(x) result(res)
integer(4), dimension(:), intent(in) :: x
integer(4) :: res
res = size (x, 1)
end function
pure function elements_uncommon_with(x) result(res)
integer(4), dimension(:), intent(in) :: x
integer(4), dimension(n_elements_uncommon_with_(x)) :: res
res = x
end function
end module test
use test
integer(4) :: z(4)
z = 1
print *, elements_uncommon_with (z)
print *, n_elements_uncommon_with_ (z)
end
! { dg-final { cleanup-modules "test" } }