From 7e2791428f91a88bfe3762fa1456f435fc25e2b0 Mon Sep 17 00:00:00 2001 From: Jakub Jelinek Date: Thu, 14 May 2009 02:00:27 +0200 Subject: [PATCH] re PR fortran/39865 (ICE in gfc_conv_scalarized_array_ref) PR fortran/39865 * io.c (resolve_tag_format): CHARACTER array in FMT= argument isn't an extension. Reject non-CHARACTER array element of assumed shape or pointer or assumed size array. * trans-array.c (array_parameter_size): New function. (gfc_conv_array_parameter): Add size argument. Call array_parameter_size if it is non-NULL. * trans-array.h (gfc_conv_array_parameter): Adjust prototype. * trans-expr.c (gfc_conv_function_call, gfc_trans_arrayfunc_assign): Adjust callers. * trans-intrinsic.c (gfc_conv_intrinsic_loc): Likewise. * trans-io.c (gfc_convert_array_to_string): Rewritten. * gfortran.dg/pr39865.f90: New test. * gfortran.dg/hollerith.f90: Don't expect errors for CHARACTER arrays in FMT=. * gfortran.dg/hollerith_f95.f90: Likewise. * gfortran.dg/hollerith6.f90: New test. * gfortran.dg/hollerith7.f90: New test. From-SVN: r147507 --- gcc/fortran/ChangeLog | 15 ++++ gcc/fortran/io.c | 43 +++++++---- gcc/fortran/trans-array.c | 44 ++++++++++- gcc/fortran/trans-array.h | 2 +- gcc/fortran/trans-expr.c | 7 +- gcc/fortran/trans-intrinsic.c | 2 +- gcc/fortran/trans-io.c | 84 ++++++++++----------- gcc/testsuite/ChangeLog | 10 +++ gcc/testsuite/gfortran.dg/hollerith.f90 | 6 -- gcc/testsuite/gfortran.dg/hollerith6.f90 | 35 +++++++++ gcc/testsuite/gfortran.dg/hollerith7.f90 | 52 +++++++++++++ gcc/testsuite/gfortran.dg/hollerith_f95.f90 | 7 -- gcc/testsuite/gfortran.dg/pr39865.f90 | 84 +++++++++++++++++++++ 13 files changed, 311 insertions(+), 80 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/hollerith6.f90 create mode 100644 gcc/testsuite/gfortran.dg/hollerith7.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr39865.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 07984071988..db5f3731722 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2009-05-14 Jakub Jelinek + + PR fortran/39865 + * io.c (resolve_tag_format): CHARACTER array in FMT= argument + isn't an extension. Reject non-CHARACTER array element of + assumed shape or pointer or assumed size array. + * trans-array.c (array_parameter_size): New function. + (gfc_conv_array_parameter): Add size argument. Call + array_parameter_size if it is non-NULL. + * trans-array.h (gfc_conv_array_parameter): Adjust prototype. + * trans-expr.c (gfc_conv_function_call, gfc_trans_arrayfunc_assign): + Adjust callers. + * trans-intrinsic.c (gfc_conv_intrinsic_loc): Likewise. + * trans-io.c (gfc_convert_array_to_string): Rewritten. + 2009-05-13 Steven G. Kargl * gfortran.h (gfc_code): Rename struct member expr to expr1. diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index eb0e3ae6b28..c902257f095 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1,5 +1,5 @@ /* Deal with I/O statements & related stuff. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -1234,8 +1234,11 @@ resolve_tag_format (const gfc_expr *e) /* If e's rank is zero and e is not an element of an array, it should be of integer or character type. The integer variable should be ASSIGNED. */ - if (e->symtree == NULL || e->symtree->n.sym->as == NULL - || e->symtree->n.sym->as->rank == 0) + if (e->rank == 0 + && (e->expr_type != EXPR_VARIABLE + || e->symtree == NULL + || e->symtree->n.sym->as == NULL + || e->symtree->n.sym->as->rank == 0)) { if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER) { @@ -1266,20 +1269,34 @@ resolve_tag_format (const gfc_expr *e) return SUCCESS; } - /* If rank is nonzero, we allow the type to be character under GFC_STD_GNU - and other type under GFC_STD_LEGACY. It may be assigned an Hollerith - constant. */ - if (e->ts.type == BT_CHARACTER) - { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array " - "in FORMAT tag at %L", &e->where) == FAILURE) - return FAILURE; - } - else + /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY. + It may be assigned an Hollerith constant. */ + if (e->ts.type != BT_CHARACTER) { if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character " "in FORMAT tag at %L", &e->where) == FAILURE) return FAILURE; + + if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Non-character assumed shape array element in FORMAT" + " tag at %L", &e->where); + return FAILURE; + } + + if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Non-character assumed size array element in FORMAT" + " tag at %L", &e->where); + return FAILURE; + } + + if (e->rank == 0 && e->symtree->n.sym->attr.pointer) + { + gfc_error ("Non-character pointer array element in FORMAT tag at %L", + &e->where); + return FAILURE; + } } return SUCCESS; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 71db46d18b2..f4276ca133c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5339,13 +5339,41 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gfc_cleanup_loop (&loop); } +/* Helper function for gfc_conv_array_parameter if array size needs to be + computed. */ + +static void +array_parameter_size (tree desc, gfc_expr *expr, tree *size) +{ + tree elem; + if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); + else if (expr->rank > 1) + *size = build_call_expr (gfor_fndecl_size0, 1, + gfc_build_addr_expr (NULL, desc)); + else + { + tree ubound = gfc_conv_descriptor_ubound (desc, gfc_index_zero_node); + tree lbound = gfc_conv_descriptor_lbound (desc, gfc_index_zero_node); + + *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); + *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size, + gfc_index_one_node); + *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size, + gfc_index_zero_node); + } + elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); + *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size, + fold_convert (gfc_array_index_type, elem)); +} /* Convert an array for passing as an actual parameter. */ /* TODO: Optimize passing g77 arrays. */ void gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, - const gfc_symbol *fsym, const char *proc_name) + const gfc_symbol *fsym, const char *proc_name, + tree *size) { tree ptr; tree desc; @@ -5394,6 +5422,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, se->expr = tmp; else se->expr = gfc_build_addr_expr (NULL_TREE, tmp); + if (size) + array_parameter_size (tmp, expr, size); return; } if (sym->attr.allocatable) @@ -5401,10 +5431,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, if (sym->attr.dummy || sym->attr.result) { gfc_conv_expr_descriptor (se, expr, ss); - se->expr = gfc_conv_array_data (se->expr); + tmp = se->expr; } - else - se->expr = gfc_conv_array_data (tmp); + if (size) + array_parameter_size (tmp, expr, size); + se->expr = gfc_conv_array_data (tmp); return; } } @@ -5413,6 +5444,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, { /* Result of the enclosing function. */ gfc_conv_expr_descriptor (se, expr, ss); + if (size) + array_parameter_size (se->expr, expr, size); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE @@ -5426,6 +5459,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77, /* Every other type of array. */ se->want_pointer = 1; gfc_conv_expr_descriptor (se, expr, ss); + if (size) + array_parameter_size (build_fold_indirect_ref (se->expr), + expr, size); } /* Deallocate the allocatable components of structures that are diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 49818d4fe6d..3f8809d84c6 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -106,7 +106,7 @@ void gfc_conv_tmp_ref (gfc_se *); void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *); /* Convert an array for passing as an actual function parameter. */ void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int, - const gfc_symbol *, const char *); + const gfc_symbol *, const char *, tree *); /* Evaluate and transpose a matrix expression. */ void gfc_conv_array_transpose (gfc_se *, gfc_expr *); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 70c44f32968..cf17598c9f6 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2424,7 +2424,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, f = f || !sym->attr.always_explicit; argss = gfc_walk_expr (arg->expr); - gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL); + gfc_conv_array_parameter (se, arg->expr, argss, f, + NULL, NULL, NULL); } /* TODO -- the following two lines shouldn't be necessary, but @@ -2676,7 +2677,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fsym ? fsym->attr.intent : INTENT_INOUT); else gfc_conv_array_parameter (&parmse, e, argss, f, fsym, - sym->name); + sym->name, NULL); /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ @@ -4352,7 +4353,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_start_block (&se.pre); se.want_pointer = 1; - gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL); + gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL); se.direct_byref = 1; se.ss = gfc_walk_expr (expr2); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index d00a35b5eb8..33cc7f569a3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4394,7 +4394,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) if (ss == gfc_ss_terminator) gfc_conv_expr_reference (se, arg_expr); else - gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL); + gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL); se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); /* Create a temporary variable for loc return value. Without this, diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 09f35b79c90..24f156ef0aa 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -567,65 +567,57 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, /* Given an array expr, find its address and length to get a string. If the array is full, the string's address is the address of array's first element - and the length is the size of the whole array. If it is an element, the + and the length is the size of the whole array. If it is an element, the string's address is the element's address and the length is the rest size of - the array. -*/ + the array. */ static void gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) { - tree tmp; - tree array; - tree type; tree size; - int rank; - gfc_symbol *sym; - sym = e->symtree->n.sym; - rank = sym->as->rank - 1; + if (e->rank == 0) + { + tree type, array, tmp; + gfc_symbol *sym; + int rank; - if (e->ref->u.ar.type == AR_FULL) - { - se->expr = gfc_get_symbol_decl (sym); - se->expr = gfc_conv_array_data (se->expr); - } - else - { + /* If it is an element, we need its address and size of the rest. */ + gcc_assert (e->expr_type == EXPR_VARIABLE); + gcc_assert (e->ref->u.ar.type == AR_ELEMENT); + sym = e->symtree->n.sym; + rank = sym->as->rank - 1; gfc_conv_expr (se, e); - } - array = sym->backend_decl; - type = TREE_TYPE (array); + array = sym->backend_decl; + type = TREE_TYPE (array); - if (GFC_ARRAY_TYPE_P (type)) - size = GFC_TYPE_ARRAY_SIZE (type); - else - { - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - size = gfc_conv_array_stride (array, rank); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_array_ubound (array, rank), - gfc_conv_array_lbound (array, rank)); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, - gfc_index_one_node); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size); - } + if (GFC_ARRAY_TYPE_P (type)) + size = GFC_TYPE_ARRAY_SIZE (type); + else + { + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + size = gfc_conv_array_stride (array, rank); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + gfc_conv_array_ubound (array, rank), + gfc_conv_array_lbound (array, rank)); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, + gfc_index_one_node); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size); + } + gcc_assert (size); - gcc_assert (size); - - /* If it is an element, we need the its address and size of the rest. */ - if (e->ref->u.ar.type == AR_ELEMENT) - { size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, - TREE_OPERAND (se->expr, 1)); + TREE_OPERAND (se->expr, 1)); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, + fold_convert (gfc_array_index_type, tmp)); + se->string_length = fold_convert (gfc_charlen_type_node, size); + return; } - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, - fold_convert (gfc_array_index_type, tmp)); - + gfc_conv_array_parameter (se, e, gfc_walk_expr (e), 1, NULL, NULL, &size); se->string_length = fold_convert (gfc_charlen_type_node, size); } @@ -654,7 +646,9 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, var, p->field_len, NULL_TREE); /* Integer variable assigned a format label. */ - if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1) + if (e->ts.type == BT_INTEGER + && e->rank == 0 + && e->symtree->n.sym->attr.assign == 1) { char * msg; tree cond; @@ -680,7 +674,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, if (e->ts.type == BT_CHARACTER && e->rank == 0) gfc_conv_expr (&se, e); /* Array assigned Hollerith constant or character array. */ - else if (e->symtree && (e->symtree->n.sym->as->rank > 0)) + else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0)) gfc_convert_array_to_string (&se, e); else gcc_unreachable (); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f9580aa46a6..fe0bb0042d6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2009-05-14 Jakub Jelinek + + PR fortran/39865 + * gfortran.dg/pr39865.f90: New test. + * gfortran.dg/hollerith.f90: Don't expect errors for CHARACTER + arrays in FMT=. + * gfortran.dg/hollerith_f95.f90: Likewise. + * gfortran.dg/hollerith6.f90: New test. + * gfortran.dg/hollerith7.f90: New test. + 2009-05-14 Manuel Lopez-Ibanez PR cpp/36674 diff --git a/gcc/testsuite/gfortran.dg/hollerith.f90 b/gcc/testsuite/gfortran.dg/hollerith.f90 index f9836155b57..21cbf66bdf6 100644 --- a/gcc/testsuite/gfortran.dg/hollerith.f90 +++ b/gcc/testsuite/gfortran.dg/hollerith.f90 @@ -99,10 +99,4 @@ end subroutine ! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 39 } -! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 43 } - -! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 45 } - -! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 47 } - ! { dg-warning "Hollerith constant" "" { target *-*-* } 51 } diff --git a/gcc/testsuite/gfortran.dg/hollerith6.f90 b/gcc/testsuite/gfortran.dg/hollerith6.f90 new file mode 100644 index 00000000000..93e857dd511 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/hollerith6.f90 @@ -0,0 +1,35 @@ +! PR fortran/39865 +! { dg-do run } + +subroutine foo (a) + integer(kind=4) :: a(1, 3) + character(len=40) :: t + write (t, fmt=a(1,2)) 1, 2, 3, 4, 5, 6, 7, 8 + if (t .ne. ' 1 2 3 4 5 6 7 8') call abort +end subroutine foo + interface + subroutine foo (a) + integer(kind=4) :: a(1, 3) + end subroutine foo + end interface + integer(kind=4) :: b(1,3) + character(len=40) :: t + b(1,1) = 4HXXXX + b(1,2) = 4H (8I + b(1,3) = 2H4) + write (t, fmt=b(1,2)) 1, 2, 3, 4, 5, 6, 7, 8 + if (t .ne. ' 1 2 3 4 5 6 7 8') call abort + call foo (b) +end + +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 7 } +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 20 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 17 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 17 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 18 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 18 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 19 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 19 } diff --git a/gcc/testsuite/gfortran.dg/hollerith7.f90 b/gcc/testsuite/gfortran.dg/hollerith7.f90 new file mode 100644 index 00000000000..8e2fb4fec12 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/hollerith7.f90 @@ -0,0 +1,52 @@ +! PR fortran/39865 +! { dg-do compile } + +subroutine foo (a) + integer(kind=4), target :: a(1:, 1:) + integer(kind=4), pointer :: b(:, :) + b => a + write (*, fmt=a(1,2)) 1, 2, 3, 4, 5, 6, 7, 8 + write (*, fmt=b(1,2)) 1, 2, 3, 4, 5, 6, 7, 8 +end subroutine foo +subroutine bar (a, b) + character :: b(2,*) + integer :: a(*) + write (*, fmt=b) 1, 2, 3 + write (*, fmt=a) 1, 2, 3 + write (*, fmt=a(2)) 1, 2, 3 +end subroutine + interface + subroutine foo (a) + integer(kind=4), target :: a(:, :) + end subroutine foo + end interface + integer(kind=4) :: a(2, 3) + a = 4HXXXX + a(2,2) = 4H (8I + a(1,3) = 2H4) + a(2,3) = 1H + call foo (a(2:2,:)) +end + +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 8 } +! { dg-error "Non-character assumed shape array element in FORMAT tag" "element" { target *-*-* } 8 } + +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 9 } +! { dg-error "Non-character pointer array element in FORMAT tag" "element" { target *-*-* } 9 } + +! { dg-error "reference to the assumed size array" "assumed-size" { target *-*-* } 14 } +! { dg-error "reference to the assumed size array" "assumed-size" { target *-*-* } 15 } +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 16 } +! { dg-error "Non-character assumed size array element in FORMAT tag" "element" { target *-*-* } 16 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 24 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 24 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 25 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 25 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 26 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 26 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 27 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 27 } diff --git a/gcc/testsuite/gfortran.dg/hollerith_f95.f90 b/gcc/testsuite/gfortran.dg/hollerith_f95.f90 index 1ba74036c26..4d7fda8c72e 100644 --- a/gcc/testsuite/gfortran.dg/hollerith_f95.f90 +++ b/gcc/testsuite/gfortran.dg/hollerith_f95.f90 @@ -91,10 +91,3 @@ end subroutine ! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 38 } ! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 40 } - -! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 44 } - -! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 46 } - -! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 48 } - diff --git a/gcc/testsuite/gfortran.dg/pr39865.f90 b/gcc/testsuite/gfortran.dg/pr39865.f90 new file mode 100644 index 00000000000..fac34367422 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr39865.f90 @@ -0,0 +1,84 @@ +! PR fortran/39865 +! { dg-do run } + +subroutine f1 (a) + character(len=1) :: a(7:) + character(len=12) :: b + character(len=1) :: c(2:10) + write (b, a) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') call abort + write (b, a(:)) 'hell', 'o Wo', 'rld!' + if (b .ne. 'hello World!') call abort + write (b, a(8:)) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') call abort + c(2) = ' ' + c(3) = '(' + c(4) = '3' + c(5) = 'A' + c(6) = '4' + c(7) = ')' + write (b, c) 'hell', 'o Wo', 'rld!' + if (b .ne. 'hello World!') call abort + write (b, c(:)) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') call abort + write (b, c(3:)) 'hell', 'o Wo', 'rld!' + if (b .ne. 'hello World!') call abort +end subroutine f1 + +subroutine f2 (a) + character(len=1) :: a(10:,20:) + character(len=12) :: b + write (b, a) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') call abort + write (b, a) 'hell', 'o Wo', 'rld!' + if (b .ne. 'hello World!') call abort +end subroutine f2 + +function f3 () + character(len=1) :: f3(5) + f3(1) = '(' + f3(2) = '3' + f3(3) = 'A' + f3(4) = '4' + f3(5) = ')' +end function f3 + + interface + subroutine f1 (a) + character(len=1) :: a(:) + end + end interface + interface + subroutine f2 (a) + character(len=1) :: a(:,:) + end + end interface + interface + function f3 () + character(len=1) :: f3(5) + end + end interface + integer :: i, j + character(len=1) :: e (6, 7:9), f (3,2), g (10) + character(len=12) :: b + e = 'X' + e(2,8) = ' ' + e(3,8) = '(' + e(4,8) = '3' + e(2,9) = 'A' + e(3,9) = '4' + e(4,9) = ')' + f = e(2:4,8:9) + g = 'X' + g(2) = ' ' + g(3) = '(' + g(4) = '3' + g(5) = 'A' + g(6) = '4' + g(7) = ')' + call f1 (g(2:7)) + call f2 (f) + call f2 (e(2:4,8:9)) + write (b, f3 ()) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') call abort +end