From 10b074327671ad5de7bf4500141137c31a9e4b8b Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 16 Apr 2006 03:45:24 +0000 Subject: [PATCH] 2006-04-16 Paul Thomas 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 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 --- gcc/fortran/ChangeLog | 34 ++++++++++ gcc/fortran/expr.c | 46 +++++++++++-- gcc/fortran/intrinsic.c | 2 +- gcc/fortran/resolve.c | 10 ++- gcc/fortran/trans-array.c | 32 ++++++++- gcc/fortran/trans-decl.c | 6 ++ gcc/fortran/trans-expr.c | 10 ++- gcc/fortran/trans-intrinsic.c | 1 + gcc/testsuite/ChangeLog | 22 ++++++ gcc/testsuite/gfortran.dg/array_return_value_1.f90 | 24 +++++++ .../auto_char_pointer_array_result_1.f90 | 36 ++++++++++ .../gfortran.dg/auto_pointer_array_result_1.f90 | 36 ++++++++++ gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 | 64 ++++++++++++++++++ gcc/testsuite/gfortran.dg/namelist_4.f90 | 5 +- gcc/testsuite/gfortran.dg/proc_assign_1.f90 | 78 ++++++++++++++++++++++ gcc/testsuite/gfortran.dg/procedure_lvalue.f90 | 2 +- .../specification_type_resolution_1.f90 | 31 +++++++++ 17 files changed, 427 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/array_return_value_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/proc_assign_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index df5a576..24af5f6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,37 @@ +2006-04-16 Paul Thomas + + 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 * trans-io.c (set_string): Use fold_build2 and build_int_cst instead diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index dfbbed2..5ecc829 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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) { diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 707fe5b..7828922 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bde11a5..f7acb73 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 4bdc784..fe8d13c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 2a9c0db..4efe4bd 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 81e0a7c..4eceab6 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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; } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index b69ffef..1abc79a 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f8f2c51..d02f439 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,25 @@ +2006-04-16 Paul Thomas + + 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 PR fortran/25336 diff --git a/gcc/testsuite/gfortran.dg/array_return_value_1.f90 b/gcc/testsuite/gfortran.dg/array_return_value_1.f90 new file mode 100644 index 0000000..45699ff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_return_value_1.f90 @@ -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 +! + 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 + diff --git a/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 b/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 new file mode 100644 index 0000000..8e3eb94 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 @@ -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 + + diff --git a/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 b/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 new file mode 100644 index 0000000..7e7cde5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 @@ -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 + + diff --git a/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 b/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 new file mode 100644 index 0000000..a277566 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 @@ -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 + + diff --git a/gcc/testsuite/gfortran.dg/namelist_4.f90 b/gcc/testsuite/gfortran.dg/namelist_4.f90 index 9e62a1f..52a5bc9 100644 --- a/gcc/testsuite/gfortran.dg/namelist_4.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_4.f90 @@ -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() diff --git a/gcc/testsuite/gfortran.dg/proc_assign_1.f90 b/gcc/testsuite/gfortran.dg/proc_assign_1.f90 new file mode 100644 index 0000000..a0f7250 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_assign_1.f90 @@ -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 +! +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" } } \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 b/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 index 2a2c355..634eaca 100644 --- a/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 +++ b/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 b/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 new file mode 100644 index 0000000..b830b5d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 @@ -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" } } -- 2.7.4