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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@112981
138bc75d-0d04-0410-961f-
82ee72b054a4
+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
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)
{
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);
{
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;
}
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;
}
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++)
/* 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);
{
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)
{
gfc_charlen cl;
gfc_expr *e;
gfc_symbol *fsym;
+ stmtblock_t post;
arglist = NULL_TREE;
retargs = NULL_TREE;
else
info = NULL;
+ gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
&& sym->ts.cl->length
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. */
}
}
+ /* 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;
}
newss->type = GFC_SS_INTRINSIC;
newss->expr = expr;
newss->next = ss;
+ newss->data.info.dimen = 1;
return newss;
}
+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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
+
--- /dev/null
+! { 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
+
+
--- /dev/null
+! { 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
+
+
CONTAINS\r
! This has the additional wrinkle of a reference to the object.\r
INTEGER FUNCTION F1()\r
- NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }\r
- f2 = 1 ! Used to ICE here\r
+ NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }
+! Used to ICE here\r
+ f2 = 1 ! { dg-error "is not a VALUE" }\r
F1=1\r
END FUNCTION\r
INTEGER FUNCTION F2()\r
--- /dev/null
+! { dg-do compile }\r
+! This tests the patch for PR26787 in which it was found that setting\r
+! the result of one module procedure from within another produced an\r
+! ICE rather than an error.\r
+!\r
+! This is an "elaborated" version of the original testcase from\r
+! Joshua Cogliati <jjcogliati-r1@yahoo.com>\r
+!\r
+function ext1 ()\r
+ integer ext1, ext2, arg\r
+ ext1 = 1\r
+ entry ext2 (arg)\r
+ ext2 = arg\r
+contains\r
+ subroutine int_1 ()\r
+ ext1 = arg * arg ! OK - host associated.\r
+ end subroutine int_1\r
+end function ext1\r
+\r
+module simple\r
+ implicit none\r
+contains\r
+ integer function foo () \r
+ foo = 10 ! OK - function result\r
+ call foobar ()\r
+ contains\r
+ subroutine foobar ()\r
+ integer z\r
+ foo = 20 ! OK - host associated.\r
+ end subroutine foobar\r
+ end function foo\r
+ subroutine bar() ! This was the original bug.\r
+ foo = 10 ! { dg-error "is not a VALUE" }\r
+ end subroutine bar\r
+ integer function oh_no ()\r
+ oh_no = 1\r
+ foo = 5 ! { dg-error "is not a VALUE" }\r
+ end function oh_no\r
+end module simple\r
+\r
+module simpler\r
+ implicit none\r
+contains\r
+ integer function foo_er () \r
+ foo_er = 10 ! OK - function result\r
+ end function foo_er\r
+end module simpler\r
+\r
+ use simpler\r
+ real w, stmt_fcn\r
+ interface\r
+ function ext1 ()\r
+ integer ext1\r
+ end function ext1\r
+ function ext2 (arg)\r
+ integer ext2, arg\r
+ end function ext2\r
+ end interface\r
+ stmt_fcn (w) = sin (w) \r
+ call x (y ())\r
+ x = 10 ! { dg-error "Expected VARIABLE" }\r
+ y = 20 ! { dg-error "is not a VALUE" }\r
+ foo_er = 8 ! { dg-error "is not a VALUE" }\r
+ ext1 = 99 ! { dg-error "is not a VALUE" }\r
+ ext2 = 99 ! { dg-error "is not a VALUE" }\r
+ stmt_fcn = 1.0 ! { dg-error "Expected VARIABLE" }\r
+ w = stmt_fcn (1.0)\r
+contains\r
+ subroutine x (i)\r
+ integer i\r
+ y = i ! { dg-error "is not a VALUE" }\r
+ end subroutine x\r
+ function y ()\r
+ integer y\r
+ y = 2 ! OK - function result\r
+ end function y\r
+end\r
+! { dg-final { cleanup-modules "simple simpler" } }
\ No newline at end of file
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
--- /dev/null
+! { 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" } }
projects / platform / upstream / linaro-gcc.git / commitdiff