diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 43 | ||||
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 11 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 64 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 214 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 3 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 9 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/mapping_1.f90 | 70 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/mapping_2.f90 | 32 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/mapping_3.f90 | 33 |
11 files changed, 445 insertions, 37 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 200f38cbe79..50425ab4b9d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,46 @@ +2007-12-16 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/31213 + PR fortran/33888 + PR fortran/33998 + * trans-array.c (gfc_trans_array_constructor_value): If the + iterator variable does not have a backend_decl, use a local + temporary. + (get_elemental_fcn_charlen): New function to map the character + length of an elemental function onto its actual arglist. + (gfc_conv_expr_descriptor): Call the above so that the size of + the temporary can be evaluated. + * trans-expr.c : Include arith.h and change prototype of + gfc_apply_interface_mapping_to_expr to return void. Change all + references to gfc_apply_interface_mapping_to_expr accordingly. + (gfc_free_interface_mapping): Free the 'expr' field. + (gfc_add_interface_mapping): Add an argument for the actual + argument expression. This is copied to the 'expr' field of the + mapping. Only stabilize the backend_decl if the se is present. + Copy the character length expression and only add it's backend + declaration if se is present. Return without working on the + backend declaration for the new symbol if se is not present. + (gfc_map_intrinsic_function) : To simplify intrinsics 'len', + 'size', 'ubound' and 'lbound' and then to map the result. + (gfc_map_fcn_formal_to_actual): Performs the formal to actual + mapping for the case of a function found in a specification + expression in the interface being mapped. + (gfc_apply_interface_mapping_to_ref): Remove seen_result and + all its references. Remove the inline simplification of LEN + and call gfc_map_intrinsic_function instead. Change the + order of mapping of the actual arguments and simplifying + intrinsic functions. Finally, if a function maps to an + actual argument, call gfc_map_fcn_formal_to_actual. + (gfc_conv_function_call): Add 'e' to the call to + gfc_add_interface_mapping. + * dump-parse-tree.c (gfc_show_symbol_n): New function for + diagnostic purposes. + * gfortran.h : Add prototype for gfc_show_symbol_n. + * trans.h : Add 'expr' field to gfc_add_interface_mapping. + Add 'expr' to prototype for gfc_show_symbol_n. + * resolve.c (resolve_generic_f0): Set specific function as + referenced. + 2007-12-14 Tobias Burnus <burnus@net-b.de> PR fortran/34438 diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index f9c92b272e6..ea83da76cff 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -731,6 +731,17 @@ gfc_show_symbol (gfc_symbol *sym) } +/* Show a symbol for diagnostic purposes. */ +void +gfc_show_symbol_n (const char * msg, gfc_symbol *sym) +{ + if (msg) + gfc_status (msg); + gfc_show_symbol (sym); + gfc_status_char ('\n'); +} + + /* Show a user-defined operator. Just prints an operator and the name of the associated subroutine, really. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f1fe8729735..54c6ad859e7 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2364,6 +2364,7 @@ void gfc_show_namelist (gfc_namelist *); void gfc_show_namespace (gfc_namespace *); void gfc_show_ref (gfc_ref *); void gfc_show_symbol (gfc_symbol *); +void gfc_show_symbol_n (const char *, gfc_symbol *); void gfc_show_typespec (gfc_typespec *); /* parse.c */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 16543bcfb9f..0df0aa78bcd 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1425,6 +1425,8 @@ resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) else if (s->result != NULL && s->result->as != NULL) expr->rank = s->result->as->rank; + gfc_set_sym_referenced (expr->value.function.esym); + return MATCH_YES; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 17a63d2e2f4..2ebb3654579 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1225,10 +1225,21 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, loopbody = gfc_finish_block (&body); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, c->iterator->var); - gfc_add_block_to_block (pblock, &se.pre); - loopvar = se.expr; + if (c->iterator->var->symtree->n.sym->backend_decl) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->iterator->var); + gfc_add_block_to_block (pblock, &se.pre); + loopvar = se.expr; + } + else + { + /* If the iterator appears in a specification expression in + an interface mapping, we need to make a temp for the loop + variable because it is not declared locally. */ + loopvar = gfc_typenode_for_spec (&c->iterator->var->ts); + loopvar = gfc_create_var (loopvar, "loopvar"); + } /* Make a temporary, store the current value in that and return it, once the loop is done. */ @@ -4491,6 +4502,47 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, } +/* gfc_conv_expr_descriptor needs the character length of elemental + functions before the function is called so that the size of the + temporary can be obtained. The only way to do this is to convert + the expression, mapping onto the actual arguments. */ +static void +get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se) +{ + gfc_interface_mapping mapping; + gfc_formal_arglist *formal; + gfc_actual_arglist *arg; + gfc_se tse; + + formal = expr->symtree->n.sym->formal; + arg = expr->value.function.actual; + gfc_init_interface_mapping (&mapping); + + /* Set se = NULL in the calls to the interface mapping, to supress any + backend stuff. */ + for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) + { + if (!arg->expr) + continue; + if (formal->sym) + gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr); + } + + gfc_init_se (&tse, NULL); + + /* Build the expression for the character length and convert it. */ + gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length); + + gfc_add_block_to_block (&se->pre, &tse.pre); + gfc_add_block_to_block (&se->post, &tse.post); + tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); + tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr, + build_int_cst (gfc_charlen_type_node, 0)); + expr->ts.cl->backend_decl = tse.expr; + gfc_free_interface_mapping (&mapping); +} + + /* Convert an array for passing as an actual argument. Expressions and vector subscripts are evaluated and stored in a temporary, which is then passed. For whole arrays the descriptor is passed. For array sections @@ -4624,6 +4676,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) { /* Elemental function. */ need_tmp = 1; + if (expr->ts.type == BT_CHARACTER + && expr->ts.cl->length->expr_type != EXPR_CONSTANT) + get_elemental_fcn_charlen (expr, se); + info = NULL; } else diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 91c77007b35..e33df0fe0bb 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -34,6 +34,7 @@ along with GCC; see the file COPYING3. If not see #include "langhooks.h" #include "flags.h" #include "gfortran.h" +#include "arith.h" #include "trans.h" #include "trans-const.h" #include "trans-types.h" @@ -43,7 +44,7 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr); -static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, +static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, gfc_expr *); /* Copy the scalarization loop variables. */ @@ -1417,6 +1418,7 @@ gfc_free_interface_mapping (gfc_interface_mapping * mapping) { nextsym = sym->next; gfc_free_symbol (sym->new->n.sym); + gfc_free_expr (sym->expr); gfc_free (sym->new); gfc_free (sym); } @@ -1521,7 +1523,8 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc) void gfc_add_interface_mapping (gfc_interface_mapping * mapping, - gfc_symbol * sym, gfc_se * se) + gfc_symbol * sym, gfc_se * se, + gfc_expr *expr) { gfc_interface_sym_mapping *sm; tree desc; @@ -1539,6 +1542,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; new_sym->attr.flavor = sym->attr.flavor; + new_sym->attr.function = sym->attr.function; /* Create a fake symtree for it. */ root = NULL; @@ -1551,26 +1555,32 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, sm->next = mapping->syms; sm->old = sym; sm->new = new_symtree; + sm->expr = gfc_copy_expr (expr); mapping->syms = sm; /* Stabilize the argument's value. */ - se->expr = gfc_evaluate_now (se->expr, &se->pre); + if (!sym->attr.function && se) + se->expr = gfc_evaluate_now (se->expr, &se->pre); if (sym->ts.type == BT_CHARACTER) { /* Create a copy of the dummy argument's length. */ new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl); + sm->expr->ts.cl = new_sym->ts.cl; /* If the length is specified as "*", record the length that the caller is passing. We should use the callee's length in all other cases. */ - if (!new_sym->ts.cl->length) + if (!new_sym->ts.cl->length && se) { se->string_length = gfc_evaluate_now (se->string_length, &se->pre); new_sym->ts.cl->backend_decl = se->string_length; } } + if (!se) + return; + /* Use the passed value as-is if the argument is a function. */ if (sym->attr.flavor == FL_PROCEDURE) value = se->expr; @@ -1706,21 +1716,161 @@ gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping, } +/* Convert intrinsic function calls into result expressions. */ +static bool +gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping) +{ + gfc_symbol *sym; + gfc_expr *new_expr; + gfc_expr *arg1; + gfc_expr *arg2; + int d, dup; + + arg1 = expr->value.function.actual->expr; + if (expr->value.function.actual->next) + arg2 = expr->value.function.actual->next->expr; + else + arg2 = NULL; + + sym = arg1->symtree->n.sym; + + if (sym->attr.dummy) + return false; + + new_expr = NULL; + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_LEN: + /* TODO figure out why this condition is necessary. */ + if (sym->attr.function + && arg1->ts.cl->length->expr_type != EXPR_CONSTANT + && arg1->ts.cl->length->expr_type != EXPR_VARIABLE) + return false; + + new_expr = gfc_copy_expr (arg1->ts.cl->length); + break; + + case GFC_ISYM_SIZE: + if (!sym->as) + return false; + + if (arg2 && arg2->expr_type == EXPR_CONSTANT) + { + dup = mpz_get_si (arg2->value.integer); + d = dup - 1; + } + else + { + dup = sym->as->rank; + d = 0; + } + + for (; d < dup; d++) + { + gfc_expr *tmp; + tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1)); + tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d])); + if (new_expr) + new_expr = gfc_multiply (new_expr, tmp); + else + new_expr = tmp; + } + break; + + case GFC_ISYM_LBOUND: + case GFC_ISYM_UBOUND: + /* TODO These implementations of lbound and ubound do not limit if + the size < 0, according to F95's 13.14.53 and 13.14.113. */ + + if (!sym->as) + return false; + + if (arg2 && arg2->expr_type == EXPR_CONSTANT) + d = mpz_get_si (arg2->value.integer) - 1; + else + /* TODO: If the need arises, this could produce an array of + ubound/lbounds. */ + gcc_unreachable (); + + if (expr->value.function.isym->id == GFC_ISYM_LBOUND) + new_expr = gfc_copy_expr (sym->as->lower[d]); + else + new_expr = gfc_copy_expr (sym->as->upper[d]); + break; + + default: + break; + } + + gfc_apply_interface_mapping_to_expr (mapping, new_expr); + if (!new_expr) + return false; + + gfc_replace_expr (expr, new_expr); + return true; +} + + +static void +gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr, + gfc_interface_mapping * mapping) +{ + gfc_formal_arglist *f; + gfc_actual_arglist *actual; + + actual = expr->value.function.actual; + f = map_expr->symtree->n.sym->formal; + + for (; f && actual; f = f->next, actual = actual->next) + { + if (!actual->expr) + continue; + + gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr); + } + + if (map_expr->symtree->n.sym->attr.dimension) + { + int d; + gfc_array_spec *as; + + as = gfc_copy_array_spec (map_expr->symtree->n.sym->as); + + for (d = 0; d < as->rank; d++) + { + gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]); + gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]); + } + + expr->value.function.esym->as = as; + } + + if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER) + { + expr->value.function.esym->ts.cl->length + = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length); + + gfc_apply_interface_mapping_to_expr (mapping, + expr->value.function.esym->ts.cl->length); + } +} + + /* EXPR is a copy of an expression that appeared in the interface associated with MAPPING. Walk it recursively looking for references to dummy arguments that MAPPING maps to actual arguments. Replace each such reference with a reference to the associated actual argument. */ -static int +static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, gfc_expr * expr) { gfc_interface_sym_mapping *sym; gfc_actual_arglist *actual; - int seen_result = 0; if (!expr) - return 0; + return; /* Copying an expression does not copy its length, so do that here. */ if (expr->ts.type == BT_CHARACTER && expr->ts.cl) @@ -1733,17 +1883,21 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, gfc_apply_interface_mapping_to_ref (mapping, expr->ref); /* ...and to the expression's symbol, if it has one. */ - if (expr->symtree) - for (sym = mapping->syms; sym; sym = sym->next) - if (sym->old == expr->symtree->n.sym) - expr->symtree = sym->new; + /* TODO Find out why the condition on expr->symtree had to be moved into + the loop rather than being ouside it, as originally. */ + for (sym = mapping->syms; sym; sym = sym->next) + if (expr->symtree && sym->old == expr->symtree->n.sym) + { + if (sym->new->n.sym->backend_decl) + expr->symtree = sym->new; + else if (sym->expr) + gfc_replace_expr (expr, gfc_copy_expr (sym->expr)); + } - /* ...and to subexpressions in expr->value. */ + /* ...and to subexpressions in expr->value. */ switch (expr->expr_type) { case EXPR_VARIABLE: - if (expr->symtree->n.sym->attr.result) - seen_result = 1; case EXPR_CONSTANT: case EXPR_NULL: case EXPR_SUBSTRING: @@ -1755,27 +1909,22 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, break; case EXPR_FUNCTION: + for (actual = expr->value.function.actual; actual; actual = actual->next) + gfc_apply_interface_mapping_to_expr (mapping, actual->expr); + if (expr->value.function.esym == NULL && expr->value.function.isym != NULL - && expr->value.function.isym->id == GFC_ISYM_LEN - && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE - && gfc_apply_interface_mapping_to_expr (mapping, - expr->value.function.actual->expr)) - { - gfc_expr *new_expr; - new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length); - *expr = *new_expr; - gfc_free (new_expr); - gfc_apply_interface_mapping_to_expr (mapping, expr); - break; - } + && expr->value.function.actual->expr->symtree + && gfc_map_intrinsic_function (expr, mapping)) + break; for (sym = mapping->syms; sym; sym = sym->next) if (sym->old == expr->value.function.esym) - expr->value.function.esym = sym->new->n.sym; - - for (actual = expr->value.function.actual; actual; actual = actual->next) - gfc_apply_interface_mapping_to_expr (mapping, actual->expr); + { + expr->value.function.esym = sym->new->n.sym; + gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping); + expr->value.function.esym->result = sym->new->n.sym; + } break; case EXPR_ARRAY: @@ -1783,7 +1932,8 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor); break; } - return seen_result; + + return; } @@ -2351,7 +2501,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, } if (fsym && need_interface_mapping) - gfc_add_interface_mapping (&mapping, fsym, &parmse); + gfc_add_interface_mapping (&mapping, fsym, &parmse, e); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&post, &parmse.post); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 6d15fea9e9d..9ccf5713bee 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -695,6 +695,7 @@ typedef struct gfc_interface_sym_mapping struct gfc_interface_sym_mapping *next; gfc_symbol *old; gfc_symtree *new; + gfc_expr *expr; } gfc_interface_sym_mapping; @@ -716,7 +717,7 @@ gfc_interface_mapping; void gfc_init_interface_mapping (gfc_interface_mapping *); void gfc_free_interface_mapping (gfc_interface_mapping *); void gfc_add_interface_mapping (gfc_interface_mapping *, - gfc_symbol *, gfc_se *); + gfc_symbol *, gfc_se *, gfc_expr *); void gfc_finish_interface_mapping (gfc_interface_mapping *, stmtblock_t *, stmtblock_t *); void gfc_apply_interface_mapping (gfc_interface_mapping *, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 06a2195d963..dd3ce1f30fc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2007-12-16 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/31213 + PR fortran/33888 + PR fortran/33998 + * gfortran.dg/mapping_1.f90: New test. + * gfortran.dg/mapping_2.f90: New test. + * gfortran.dg/mapping_3.f90: New test. + 2007-12-16 Richard Sandiford <rsandifo@nildram.co.uk> PR rtl-optimization/34415 diff --git a/gcc/testsuite/gfortran.dg/mapping_1.f90 b/gcc/testsuite/gfortran.dg/mapping_1.f90 new file mode 100644 index 00000000000..02042c02626 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/mapping_1.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! Tests the fix for PR31213, which exposed rather a lot of +! bugs - see the PR and the ChangeLog. +! +! Contributed by Joost VandeVondele <jv244@cam.ac.uk> +! +module mykinds + implicit none + integer, parameter :: ik1 = selected_int_kind (2) + integer, parameter :: ik2 = selected_int_kind (4) + integer, parameter :: dp = selected_real_kind (15,300) +end module mykinds + +module spec_xpr + use mykinds + implicit none + integer(ik2) c_size +contains + pure function tricky (str,ugly) + character(*), intent(in) :: str + integer(ik1) :: ia_ik1(len(str)) + interface yoagly + pure function ugly(n) + use mykinds + implicit none + integer, intent(in) :: n + complex(dp) :: ugly(3*n+2) + end function ugly + end interface yoagly + logical :: la(size (yoagly (size (ia_ik1)))) + integer :: i + character(tricky_helper ((/(.TRUE., i=1, size (la))/)) + c_size) :: tricky + + tricky = transfer (yoagly (1), tricky) + end function tricky + + pure function tricky_helper (lb) + logical, intent(in) :: lb(:) + integer :: tricky_helper + tricky_helper = 2 * size (lb) + 3 + end function tricky_helper +end module spec_xpr + +module xtra_fun + implicit none +contains + pure function butt_ugly(n) + use mykinds + implicit none + integer, intent(in) :: n + complex(dp) :: butt_ugly(3*n+2) + real(dp) pi, sq2 + + pi = 4 * atan (1.0_dp) + sq2 = sqrt (2.0_dp) + butt_ugly = cmplx (pi, sq2, dp) + end function butt_ugly +end module xtra_fun + +program spec_test + use mykinds + use spec_xpr + use xtra_fun + implicit none + character(54) :: chr + + c_size = 5 + if (tricky ('Help me', butt_ugly) .ne. transfer (butt_ugly (1), chr)) call abort () +end program spec_test +! { dg-final { cleanup-modules "mykinds spec_xpr xtra_fun" } } diff --git a/gcc/testsuite/gfortran.dg/mapping_2.f90 b/gcc/testsuite/gfortran.dg/mapping_2.f90 new file mode 100644 index 00000000000..7611c42925e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/mapping_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! Tests the fix for PR33998, in which the chain of expressions +! determining the character length of my_string were not being +! resolved by the formal to actual mapping. +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +module test + implicit none + contains + function my_string(x) + integer i + real, intent(in) :: x(:) + character(0) h4(1:minval([(1,i=1,0)],1)) + character(0) sv1(size(x,1):size(h4)) + character(0) sv2(2*lbound(sv1,1):size(h4)) + character(lbound(sv2,1)-3) my_string + + do i = 1, len(my_string) + my_string(i:i) = achar(modulo(i-1,10)+iachar('0')) + end do + end function my_string +end module test + +program len_test + use test + implicit none + real x(7) + + if (my_string(x) .ne. "01234567890") call abort () +end program len_test +! { dg-final { cleanup-modules "test" } } diff --git a/gcc/testsuite/gfortran.dg/mapping_3.f90 b/gcc/testsuite/gfortran.dg/mapping_3.f90 new file mode 100644 index 00000000000..318ec00c027 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/mapping_3.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! Tests the fix for PR33888, in which the character length of +! the elemental function myfunc was not being calculated before +! the temporary for the array result was allocated. +! +! Contributed by Walter Spector <w6ws@earthlink.net> +! +program ftn95bug + implicit none + + character(8) :: indata(4) = & + (/ '12344321', '98766789', 'abcdefgh', 'ABCDEFGH' /) + + call process (myfunc (indata)) ! <- This caused a gfortran ICE ! + +contains + + elemental function myfunc (s) + character(*), intent(in) :: s + character(len (s)) :: myfunc + + myfunc = s + + end function + + subroutine process (strings) + character(*), intent(in) :: strings(:) + + if (any (strings .ne. indata)) call abort () + + end subroutine + +end program |