From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 7817) id 0D372384F00D; Sat, 5 Jun 2021 11:15:29 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 0D372384F00D MIME-Version: 1.0 Content-Transfer-Encoding: 8bit Content-Type: text/plain; charset="utf-8" From: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-1233] Fortran: Fix some issues with pointers to character. X-Act-Checkin: gcc X-Git-Author: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= X-Git-Refname: refs/heads/master X-Git-Oldrev: 96963713f6a648a0ed890450e02ebdd8ff583b14 X-Git-Newrev: d514626ee2566c68b8a79c7b99aaf791d69e1b2f Message-Id: <20210605111529.0D372384F00D@sourceware.org> Date: Sat, 5 Jun 2021 11:15:29 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Sat, 05 Jun 2021 11:15:29 -0000 https://gcc.gnu.org/g:d514626ee2566c68b8a79c7b99aaf791d69e1b2f commit r12-1233-gd514626ee2566c68b8a79c7b99aaf791d69e1b2f Author: José Rui Faustino de Sousa Date: Sat Jun 5 11:12:50 2021 +0000 Fortran: Fix some issues with pointers to character. gcc/fortran/ChangeLog: PR fortran/100120 PR fortran/100816 PR fortran/100818 PR fortran/100819 PR fortran/100821 * trans-array.c (gfc_get_array_span): rework the way character array "span" was calculated. (gfc_conv_expr_descriptor): improve handling of character sections and unlimited polymorphic objects. * trans-expr.c (gfc_get_character_len): new function to calculate character string length. (gfc_get_character_len_in_bytes): new function to calculate character string length in bytes. (gfc_conv_scalar_to_descriptor): add call to set the "span". (gfc_trans_pointer_assignment): set "_len" and antecipate the initialization of the deferred character length hidden argument. * trans-intrinsic.c (gfc_conv_associated): set "force_no_tmp" to avoid the creation of a temporary. * trans-types.c (gfc_get_dtype_rank_type): rework type detection so that unlimited polymorphic objects get proper type infomation, also important for bind(c). (gfc_get_dtype): add argument to pass the rank if necessary. (gfc_get_array_type_bounds): cosmetic change to have character arrays called character instead of unknown. * trans-types.h (gfc_get_dtype): modify prototype. * trans.c (get_array_span): rework the way character array "span" was calculated. * trans.h (gfc_get_character_len): new prototype. (gfc_get_character_len_in_bytes): new prototype. Add "unlimited_polymorphic" flag to "gfc_se" type to signal when expression carries an unlimited polymorphic object. libgfortran/ChangeLog: PR fortran/100120 * intrinsics/associated.c (associated): have associated verify if the "span" matches insted of the "elem_len". * libgfortran.h (GFC_DESCRIPTOR_SPAN): add macro to retrive the descriptor "span". gcc/testsuite/ChangeLog: PR fortran/100120 * gfortran.dg/PR100120.f90: New test. PR fortran/100816 PR fortran/100818 PR fortran/100819 PR fortran/100821 * gfortran.dg/character_workout_1.f90: New test. * gfortran.dg/character_workout_4.f90: New test. Diff: --- gcc/fortran/trans-array.c | 61 +- gcc/fortran/trans-expr.c | 70 ++- gcc/fortran/trans-intrinsic.c | 1 + gcc/fortran/trans-types.c | 68 ++- gcc/fortran/trans-types.h | 2 +- gcc/fortran/trans.c | 26 +- gcc/fortran/trans.h | 5 + gcc/testsuite/gfortran.dg/PR100120.f90 | 198 +++++++ gcc/testsuite/gfortran.dg/character_workout_1.f90 | 689 ++++++++++++++++++++++ gcc/testsuite/gfortran.dg/character_workout_4.f90 | 689 ++++++++++++++++++++++ libgfortran/intrinsics/associated.c | 2 +- libgfortran/libgfortran.h | 1 + 12 files changed, 1732 insertions(+), 80 deletions(-) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7eeef554c0f..a6bcd2b5ab7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -860,16 +860,25 @@ gfc_get_array_span (tree desc, gfc_expr *expr) size of the array. Attempt to deal with unbounded character types if possible. Otherwise, return NULL_TREE. */ tmp = gfc_get_element_type (TREE_TYPE (desc)); - if (tmp && TREE_CODE (tmp) == ARRAY_TYPE - && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE - || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp))))) - { - if (expr->expr_type == EXPR_VARIABLE - && expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, - gfc_get_expr_charlen (expr)); - else - tmp = NULL_TREE; + if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)) + { + gcc_assert (expr->ts.type == BT_CHARACTER); + + tmp = gfc_get_character_len_in_bytes (tmp); + + if (tmp == NULL_TREE || integer_zerop (tmp)) + { + tree bs; + + tmp = gfc_get_expr_charlen (expr); + tmp = fold_convert (gfc_array_index_type, tmp); + bs = build_int_cst (gfc_array_index_type, expr->ts.kind); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, bs); + } + + tmp = (tmp && !integer_zerop (tmp)) + ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE); } else tmp = fold_convert (gfc_array_index_type, @@ -7328,6 +7337,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) expr = expr->value.function.actual->expr; } + if (!se->direct_byref) + se->unlimited_polymorphic = UNLIMITED_POLY (expr); + /* Special case things we know we can pass easily. */ switch (expr->expr_type) { @@ -7351,9 +7363,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) && TREE_CODE (desc) == COMPONENT_REF) deferred_array_component = true; - subref_array_target = se->direct_byref && is_subref_array (expr); - need_tmp = gfc_ref_needs_temporary_p (expr->ref) - && !subref_array_target; + subref_array_target = (is_subref_array (expr) + && (se->direct_byref + || expr->ts.type == BT_CHARACTER)); + need_tmp = (gfc_ref_needs_temporary_p (expr->ref) + && !subref_array_target); if (se->force_tmp) need_tmp = 1; @@ -7390,9 +7404,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) subref_array_target, expr); /* ....and set the span field. */ - tmp = gfc_get_array_span (desc, expr); - if (tmp != NULL_TREE && !integer_zerop (tmp)) - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); + tmp = gfc_conv_descriptor_span_get (desc); + gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); } else if (se->want_pointer) { @@ -7607,6 +7620,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) int dim, ndim, codim; tree parm; tree parmtype; + tree dtype; tree stride; tree from; tree to; @@ -7689,7 +7703,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else { /* Otherwise make a new one. */ - if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) + if (expr->ts.type == BT_CHARACTER) parmtype = gfc_typenode_for_spec (&expr->ts); else parmtype = gfc_get_element_type (TREE_TYPE (desc)); @@ -7723,11 +7737,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } /* Set the span field. */ - if (expr->ts.type == BT_CHARACTER && ss_info->string_length) - tmp = ss_info->string_length; - else - tmp = gfc_get_array_span (desc, expr); - if (tmp != NULL_TREE) + tmp = gfc_get_array_span (desc, expr); + if (tmp) gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); /* The following can be somewhat confusing. We have two @@ -7741,7 +7752,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* Set the dtype. */ tmp = gfc_conv_descriptor_dtype (parm); - gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype)); + if (se->unlimited_polymorphic) + dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen); + else + dtype = gfc_get_dtype (parmtype); + gfc_add_modify (&loop.pre, tmp, dtype); /* The 1st element in the section. */ base = gfc_index_zero_node; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 00690fe9ed4..e3bc8863f1b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -42,6 +42,45 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" #include "gimplify.h" + +/* Calculate the number of characters in a string. */ + +tree +gfc_get_character_len (tree type) +{ + tree len; + + gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE + && TYPE_STRING_FLAG (type)); + + len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + len = (len) ? (len) : (integer_zero_node); + return fold_convert (gfc_charlen_type_node, len); +} + + + +/* Calculate the number of bytes in a string. */ + +tree +gfc_get_character_len_in_bytes (tree type) +{ + tree tmp, len; + + gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE + && TYPE_STRING_FLAG (type)); + + tmp = TYPE_SIZE_UNIT (TREE_TYPE (type)); + tmp = (tmp && !integer_zerop (tmp)) + ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE); + len = gfc_get_character_len (type); + if (tmp && len && !integer_zerop (len)) + len = fold_build2_loc (input_location, MULT_EXPR, + gfc_charlen_type_node, len, tmp); + return len; +} + + /* Convert a scalar to an array descriptor. To be used for assumed-rank arrays. */ @@ -87,6 +126,8 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), gfc_get_dtype_rank_type (0, etype)); gfc_conv_descriptor_data_set (&se->pre, desc, scalar); + gfc_conv_descriptor_span_set (&se->pre, desc, + gfc_conv_descriptor_elem_len (desc)); /* Copy pointer address back - but only if it could have changed and if the actual argument is a pointer and not, e.g., NULL(). */ @@ -9630,11 +9671,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) lse.direct_byref = 1; gfc_conv_expr_descriptor (&lse, expr2); strlen_rhs = lse.string_length; + gfc_init_se (&rse, NULL); if (expr1->ts.type == BT_CLASS) { rse.expr = NULL_TREE; - rse.string_length = NULL_TREE; + rse.string_length = strlen_rhs; trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, NULL); } @@ -9694,6 +9736,19 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_modify (&lse.pre, desc, tmp); } + if (expr1->ts.type == BT_CHARACTER + && expr1->symtree->n.sym->ts.deferred + && expr1->symtree->n.sym->ts.u.cl->backend_decl + && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl)) + { + tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl; + if (expr2->expr_type != EXPR_NULL) + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), strlen_rhs)); + else + gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp))); + } + gfc_add_block_to_block (&block, &lse.pre); if (rank_remap) gfc_add_block_to_block (&block, &rse.pre); @@ -9856,19 +9911,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) msg, rsize, lsize); } - if (expr1->ts.type == BT_CHARACTER - && expr1->symtree->n.sym->ts.deferred - && expr1->symtree->n.sym->ts.u.cl->backend_decl - && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl)) - { - tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl; - if (expr2->expr_type != EXPR_NULL) - gfc_add_modify (&block, tmp, - fold_convert (TREE_TYPE (tmp), strlen_rhs)); - else - gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp))); - } - /* Check string lengths if applicable. The check is only really added to the output code if -fbounds-check is enabled. */ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 98fa28d28c4..73b0bcc9dea 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -9080,6 +9080,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_add_block_to_block (&se->post, &arg1se.post); arg2se.want_pointer = 1; + arg2se.force_no_tmp = 1; gfc_conv_expr_descriptor (&arg2se, arg2->expr); gfc_add_block_to_block (&se->pre, &arg2se.pre); gfc_add_block_to_block (&se->post, &arg2se.post); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 9f21b3ee780..5582e404df9 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1482,6 +1482,7 @@ gfc_get_desc_dim_type (void) tree gfc_get_dtype_rank_type (int rank, tree etype) { + tree ptype; tree size; int n; tree tmp; @@ -1489,12 +1490,24 @@ gfc_get_dtype_rank_type (int rank, tree etype) tree field; vec *v = NULL; - size = TYPE_SIZE_UNIT (etype); + ptype = etype; + while (TREE_CODE (etype) == POINTER_TYPE + || TREE_CODE (etype) == ARRAY_TYPE) + { + ptype = etype; + etype = TREE_TYPE (etype); + } + + gcc_assert (etype); switch (TREE_CODE (etype)) { case INTEGER_TYPE: - n = BT_INTEGER; + if (TREE_CODE (ptype) == ARRAY_TYPE + && TYPE_STRING_FLAG (ptype)) + n = BT_CHARACTER; + else + n = BT_INTEGER; break; case BOOLEAN_TYPE: @@ -1516,27 +1529,36 @@ gfc_get_dtype_rank_type (int rank, tree etype) n = BT_DERIVED; break; - /* We will never have arrays of arrays. */ - case ARRAY_TYPE: - n = BT_CHARACTER; - if (size == NULL_TREE) - size = TYPE_SIZE_UNIT (TREE_TYPE (etype)); + case FUNCTION_TYPE: + case VOID_TYPE: + n = BT_VOID; break; - case POINTER_TYPE: - n = BT_ASSUMED; - if (TREE_CODE (TREE_TYPE (etype)) != VOID_TYPE) - size = TYPE_SIZE_UNIT (TREE_TYPE (etype)); - else - size = build_int_cst (size_type_node, 0); - break; - default: /* TODO: Don't do dtype for temporary descriptorless arrays. */ /* We can encounter strange array types for temporary arrays. */ - return gfc_index_zero_node; + gcc_unreachable (); } + switch (n) + { + case BT_CHARACTER: + gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE); + size = gfc_get_character_len_in_bytes (ptype); + break; + case BT_VOID: + gcc_assert (TREE_CODE (ptype) == POINTER_TYPE); + size = size_in_bytes (ptype); + break; + default: + size = size_in_bytes (etype); + break; + } + + gcc_assert (size); + + STRIP_NOPS (size); + size = fold_convert (size_type_node, size); tmp = get_dtype_type_node (); field = gfc_advance_chain (TYPE_FIELDS (tmp), GFC_DTYPE_ELEM_LEN); @@ -1560,17 +1582,17 @@ gfc_get_dtype_rank_type (int rank, tree etype) tree -gfc_get_dtype (tree type) +gfc_get_dtype (tree type, int * rank) { tree dtype; tree etype; - int rank; + int irnk; gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); - rank = GFC_TYPE_ARRAY_RANK (type); + irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type)); etype = gfc_get_element_type (type); - dtype = gfc_get_dtype_rank_type (rank, etype); + dtype = gfc_get_dtype_rank_type (irnk, etype); GFC_TYPE_ARRAY_DTYPE (type) = dtype; return dtype; @@ -1912,7 +1934,11 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, TYPE_TYPELESS_STORAGE (fat_type) = 1; gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type)); - tmp = TYPE_NAME (etype); + tmp = etype; + if (TREE_CODE (tmp) == ARRAY_TYPE + && TYPE_STRING_FLAG (tmp)) + tmp = TREE_TYPE (etype); + tmp = TYPE_NAME (tmp); if (tmp && TREE_CODE (tmp) == TYPE_DECL) tmp = DECL_NAME (tmp); if (tmp) diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index ff01226da56..3b45ce25666 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -114,7 +114,7 @@ int gfc_is_nodesc_array (gfc_symbol *); /* Return the DTYPE for an array. */ tree gfc_get_dtype_rank_type (int, tree); -tree gfc_get_dtype (tree); +tree gfc_get_dtype (tree, int *rank = NULL); tree gfc_get_ppc_type (gfc_component *); tree gfc_get_caf_vector_type (int dim); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 3ffa394d406..f26e91b29e2 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -371,30 +371,16 @@ get_array_span (tree type, tree decl) return gfc_conv_descriptor_span_get (decl); /* Return the span for deferred character length array references. */ - if (type && TREE_CODE (type) == ARRAY_TYPE - && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE - && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) - || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF) - && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF - || TREE_CODE (decl) == FUNCTION_DECL - || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) - == DECL_CONTEXT (decl))) - { - span = fold_convert (gfc_array_index_type, - TYPE_MAX_VALUE (TYPE_DOMAIN (type))); - span = fold_build2 (MULT_EXPR, gfc_array_index_type, - fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (TREE_TYPE (type))), - span); - } - else if (type && TREE_CODE (type) == ARRAY_TYPE - && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE - && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) + if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_STRING_FLAG (type)) { + if (TREE_CODE (decl) == PARM_DECL) + decl = build_fold_indirect_ref_loc (input_location, decl); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) span = gfc_conv_descriptor_span_get (decl); else - span = NULL_TREE; + span = gfc_get_character_len_in_bytes (type); + span = (span && !integer_zerop (span)) + ? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE); } /* Likewise for class array or pointer array references. */ else if (TREE_CODE (decl) == FIELD_DECL diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 69d3fdcfdac..d1d4a1d6a92 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -53,6 +53,9 @@ typedef struct gfc_se here. */ tree class_vptr; + /* Whether expr is a reference to an unlimited polymorphic object. */ + unsigned unlimited_polymorphic:1; + /* If set gfc_conv_variable will return an expression for the array descriptor. When set, want_pointer should also be set. If not set scalarizing variables will be substituted. */ @@ -506,6 +509,8 @@ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); /* trans-expr.c */ +tree gfc_get_character_len (tree); +tree gfc_get_character_len_in_bytes (tree); tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute); tree gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *, gfc_expr *); void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr); diff --git a/gcc/testsuite/gfortran.dg/PR100120.f90 b/gcc/testsuite/gfortran.dg/PR100120.f90 new file mode 100644 index 00000000000..c1e6c999639 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100120.f90 @@ -0,0 +1,198 @@ +! { dg-do run } +! +! Tests fix for PR100120 +! + +program main_p + + implicit none + + integer, parameter :: n = 11 + integer, parameter :: m = 7 + integer, parameter :: c = 63 + + type :: foo_t + integer :: i + end type foo_t + + type, extends(foo_t) :: bar_t + integer :: j(n) + end type bar_t + + integer, target :: ain(n) + character, target :: ac1(n) + character(len=m), target :: acn(n) + type(foo_t), target :: afd(n) + type(bar_t), target :: abd(n) + ! + class(foo_t), pointer :: spf + class(foo_t), pointer :: apf(:) + class(bar_t), pointer :: spb + class(bar_t), pointer :: apb(:) + class(*), pointer :: spu + class(*), pointer :: apu(:) + integer :: i, j + + ain = [(i, i=1,n)] + ac1 = [(achar(i+c), i=1,n)] + do i = 1, n + do j = 1, m + acn(i)(j:j) = achar(i*m+j+c-m) + end do + end do + afd%i = ain + abd%i = ain + do i = 1, n + abd(i)%j = 2*i*ain + end do + ! + spf => afd(n) + if(.not.associated(spf)) stop 1 + if(.not.associated(spf, afd(n))) stop 2 + if(spf%i/=n) stop 3 + apf => afd + if(.not.associated(apf)) stop 4 + if(.not.associated(apf, afd)) stop 5 + if(any(apf%i/=afd%i)) stop 6 + ! + spf => abd(n) + if(.not.associated(spf)) stop 7 + if(.not.associated(spf, abd(n))) stop 8 + if(spf%i/=n) stop 9 + select type(spf) + type is(bar_t) + if(any(spf%j/=2*n*ain)) stop 10 + class default + stop 11 + end select + apf => abd + if(.not.associated(apf)) stop 12 + if(.not.associated(apf, abd)) stop 13 + if(any(apf%i/=abd%i)) stop 14 + select type(apf) + type is(bar_t) + do i = 1, n + if(any(apf(i)%j/=2*i*ain)) stop 15 + end do + class default + stop 16 + end select + ! + spb => abd(n) + if(.not.associated(spb)) stop 17 + if(.not.associated(spb, abd(n))) stop 18 + if(spb%i/=n) stop 19 + if(any(spb%j/=2*n*ain)) stop 20 + apb => abd + if(.not.associated(apb)) stop 21 + if(.not.associated(apb, abd)) stop 22 + if(any(apb%i/=abd%i)) stop 23 + do i = 1, n + if(any(apb(i)%j/=2*i*ain)) stop 24 + end do + ! + spu => ain(n) + if(.not.associated(spu)) stop 25 + if(.not.associated(spu, ain(n))) stop 26 + select type(spu) + type is(integer) + if(spu/=n) stop 27 + class default + stop 28 + end select + apu => ain + if(.not.associated(apu)) stop 29 + if(.not.associated(apu, ain)) stop 30 + select type(apu) + type is(integer) + if(any(apu/=ain)) stop 31 + class default + stop 32 + end select + ! + spu => ac1(n) + if(.not.associated(spu)) stop 33 + if(.not.associated(spu, ac1(n))) stop 34 + select type(spu) + type is(character(len=*)) + if(len(spu)/=1) stop 35 + if(spu/=ac1(n)) stop 36 + class default + stop 37 + end select + apu => ac1 + if(.not.associated(apu)) stop 38 + if(.not.associated(apu, ac1)) stop 39 + select type(apu) + type is(character(len=*)) + if(len(apu)/=1) stop 40 + if(any(apu/=ac1)) stop 41 + class default + stop 42 + end select + ! + spu => acn(n) + if(.not.associated(spu)) stop 43 + if(.not.associated(spu, acn(n))) stop 44 + select type(spu) + type is(character(len=*)) + if(len(spu)/=m) stop 45 + if(spu/=acn(n)) stop 46 + class default + stop 47 + end select + apu => acn + if(.not.associated(apu)) stop 48 + if(.not.associated(apu, acn)) stop 49 + select type(apu) + type is(character(len=*)) + if(len(apu)/=m) stop 50 + if(any(apu/=acn)) stop 51 + class default + stop 52 + end select + ! + spu => afd(n) + if(.not.associated(spu)) stop 53 + if(.not.associated(spu, afd(n))) stop 54 + select type(spu) + type is(foo_t) + if(spu%i/=n) stop 55 + class default + stop 56 + end select + apu => afd + if(.not.associated(apu)) stop 57 + if(.not.associated(apu, afd)) stop 58 + select type(apu) + type is(foo_t) + if(any(apu%i/=afd%i)) stop 59 + class default + stop 60 + end select + ! + spu => abd(n) + if(.not.associated(spu)) stop 61 + if(.not.associated(spu, abd(n))) stop 62 + select type(spu) + type is(bar_t) + if(spu%i/=n) stop 63 + if(any(spu%j/=2*n*ain)) stop 64 + class default + stop 65 + end select + apu => abd + if(.not.associated(apu)) stop 66 + if(.not.associated(apu, abd)) stop 67 + select type(apu) + type is(bar_t) + if(any(apu%i/=abd%i)) stop 68 + do i = 1, n + if(any(apu(i)%j/=2*i*ain)) stop 69 + end do + class default + stop 70 + end select + stop + +end program main_p diff --git a/gcc/testsuite/gfortran.dg/character_workout_1.f90 b/gcc/testsuite/gfortran.dg/character_workout_1.f90 new file mode 100644 index 00000000000..98133b48960 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/character_workout_1.f90 @@ -0,0 +1,689 @@ +! { dg-do run } +! +! Tests fix for PR100120/100816/100818/100819/100821 +! + +program main_p + + implicit none + + integer, parameter :: k = 1 + integer, parameter :: n = 11 + integer, parameter :: m = 7 + integer, parameter :: l = 3 + integer, parameter :: u = 5 + integer, parameter :: e = u-l+1 + integer, parameter :: c = 61 + + character(kind=k), target :: c1(n) + character(len=m, kind=k), target :: cm(n) + ! + character(kind=k), pointer :: s1 + character(len=m, kind=k), pointer :: sm + character(len=e, kind=k), pointer :: se + character(len=:, kind=k), pointer :: sd + ! + character(kind=k), pointer :: p1(:) + character(len=m, kind=k), pointer :: pm(:) + character(len=e, kind=k), pointer :: pe(:) + character(len=:, kind=k), pointer :: pd(:) + + class(*), pointer :: su + class(*), pointer :: pu(:) + + integer :: i, j + + nullify(s1, sm, se, sd, su) + nullify(p1, pm, pe, pd, pu) + c1 = [(char(i+c, kind=k), i=1,n)] + do i = 1, n + do j = 1, m + cm(i)(j:j) = char(i*m+j+c-m, kind=k) + end do + end do + + s1 => c1(n) + if(.not.associated(s1)) stop 1 + if(.not.associated(s1, c1(n))) stop 2 + if(len(s1)/=1) stop 3 + if(s1/=c1(n)) stop 4 + call schar_c1(s1) + call schar_a1(s1) + p1 => c1 + if(.not.associated(p1)) stop 5 + if(.not.associated(p1, c1)) stop 6 + if(len(p1)/=1) stop 7 + if(any(p1/=c1)) stop 8 + call achar_c1(p1) + call achar_a1(p1) + ! + sm => cm(n) + if(.not.associated(sm)) stop 9 + if(.not.associated(sm, cm(n))) stop 10 + if(len(sm)/=m) stop 11 + if(sm/=cm(n)) stop 12 + call schar_cm(sm) + call schar_am(sm) + pm => cm + if(.not.associated(pm)) stop 13 + if(.not.associated(pm, cm)) stop 14 + if(len(pm)/=m) stop 15 + if(any(pm/=cm)) stop 16 + call achar_cm(pm) + call achar_am(pm) + ! + se => cm(n)(l:u) + if(.not.associated(se)) stop 17 + if(.not.associated(se, cm(n)(l:u))) stop 18 + if(len(se)/=e) stop 19 + if(se/=cm(n)(l:u)) stop 20 + call schar_ce(se) + call schar_ae(se) + pe => cm(:)(l:u) + if(.not.associated(pe)) stop 21 + if(.not.associated(pe, cm(:)(l:u))) stop 22 + if(len(pe)/=e) stop 23 + if(any(pe/=cm(:)(l:u))) stop 24 + call achar_ce(pe) + call achar_ae(pe) + ! + sd => c1(n) + if(.not.associated(sd)) stop 25 + if(.not.associated(sd, c1(n))) stop 26 + if(len(sd)/=1) stop 27 + if(sd/=c1(n)) stop 28 + call schar_d1(sd) + pd => c1 + if(.not.associated(pd)) stop 29 + if(.not.associated(pd, c1)) stop 30 + if(len(pd)/=1) stop 31 + if(any(pd/=c1)) stop 32 + call achar_d1(pd) + ! + sd => cm(n) + if(.not.associated(sd)) stop 33 + if(.not.associated(sd, cm(n))) stop 34 + if(len(sd)/=m) stop 35 + if(sd/=cm(n)) stop 36 + call schar_dm(sd) + pd => cm + if(.not.associated(pd)) stop 37 + if(.not.associated(pd, cm)) stop 38 + if(len(pd)/=m) stop 39 + if(any(pd/=cm)) stop 40 + call achar_dm(pd) + ! + sd => cm(n)(l:u) + if(.not.associated(sd)) stop 41 + if(.not.associated(sd, cm(n)(l:u))) stop 42 + if(len(sd)/=e) stop 43 + if(sd/=cm(n)(l:u)) stop 44 + call schar_de(sd) + pd => cm(:)(l:u) + if(.not.associated(pd)) stop 45 + if(.not.associated(pd, cm(:)(l:u))) stop 46 + if(len(pd)/=e) stop 47 + if(any(pd/=cm(:)(l:u))) stop 48 + call achar_de(pd) + ! + sd => c1(n) + s1 => sd + if(.not.associated(s1)) stop 49 + if(.not.associated(s1, c1(n))) stop 50 + if(len(s1)/=1) stop 51 + if(s1/=c1(n)) stop 52 + call schar_c1(s1) + call schar_a1(s1) + pd => c1 + s1 => pd(n) + if(.not.associated(s1)) stop 53 + if(.not.associated(s1, c1(n))) stop 54 + if(len(s1)/=1) stop 55 + if(s1/=c1(n)) stop 56 + call schar_c1(s1) + call schar_a1(s1) + pd => c1 + p1 => pd + if(.not.associated(p1)) stop 57 + if(.not.associated(p1, c1)) stop 58 + if(len(p1)/=1) stop 59 + if(any(p1/=c1)) stop 60 + call achar_c1(p1) + call achar_a1(p1) + ! + sd => cm(n) + sm => sd + if(.not.associated(sm)) stop 61 + if(.not.associated(sm, cm(n))) stop 62 + if(len(sm)/=m) stop 63 + if(sm/=cm(n)) stop 64 + call schar_cm(sm) + call schar_am(sm) + pd => cm + sm => pd(n) + if(.not.associated(sm)) stop 65 + if(.not.associated(sm, cm(n))) stop 66 + if(len(sm)/=m) stop 67 + if(sm/=cm(n)) stop 68 + call schar_cm(sm) + call schar_am(sm) + pd => cm + pm => pd + if(.not.associated(pm)) stop 69 + if(.not.associated(pm, cm)) stop 70 + if(len(pm)/=m) stop 71 + if(any(pm/=cm)) stop 72 + call achar_cm(pm) + call achar_am(pm) + ! + sd => cm(n)(l:u) + se => sd + if(.not.associated(se)) stop 73 + if(.not.associated(se, cm(n)(l:u))) stop 74 + if(len(se)/=e) stop 75 + if(se/=cm(n)(l:u)) stop 76 + call schar_ce(se) + call schar_ae(se) + pd => cm(:)(l:u) + pe => pd + if(.not.associated(pe)) stop 77 + if(.not.associated(pe, cm(:)(l:u))) stop 78 + if(len(pe)/=e) stop 79 + if(any(pe/=cm(:)(l:u))) stop 80 + call achar_ce(pe) + call achar_ae(pe) + ! + su => c1(n) + if(.not.associated(su)) stop 81 + if(.not.associated(su, c1(n))) stop 82 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 83 + if(su/=c1(n)) stop 84 + class default + stop 85 + end select + call schar_u1(su) + pu => c1 + if(.not.associated(pu)) stop 86 + if(.not.associated(pu, c1)) stop 87 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=1) stop 88 + if(any(pu/=c1)) stop 89 + class default + stop 90 + end select + call achar_u1(pu) + ! + su => cm(n) + if(.not.associated(su)) stop 91 + if(.not.associated(su)) stop 92 + if(.not.associated(su, cm(n))) stop 93 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 94 + if(su/=cm(n)) stop 95 + class default + stop 96 + end select + call schar_um(su) + pu => cm + if(.not.associated(pu)) stop 97 + if(.not.associated(pu, cm)) stop 98 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=m) stop 99 + if(any(pu/=cm)) stop 100 + class default + stop 101 + end select + call achar_um(pu) + ! + su => cm(n)(l:u) + if(.not.associated(su)) stop 102 + if(.not.associated(su, cm(n)(l:u))) stop 103 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 104 + if(su/=cm(n)(l:u)) stop 105 + class default + stop 106 + end select + call schar_ue(su) + pu => cm(:)(l:u) + if(.not.associated(pu)) stop 107 + if(.not.associated(pu, cm(:)(l:u))) stop 108 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 109 + if(any(pu/=cm(:)(l:u))) stop 110 + class default + stop 111 + end select + call achar_ue(pu) + ! + sd => c1(n) + su => sd + if(.not.associated(su)) stop 112 + if(.not.associated(su, c1(n))) stop 113 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 114 + if(su/=c1(n)) stop 115 + class default + stop 116 + end select + call schar_u1(su) + pd => c1 + su => pd(n) + if(.not.associated(su)) stop 117 + if(.not.associated(su, c1(n))) stop 118 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 119 + if(su/=c1(n)) stop 120 + class default + stop 121 + end select + call schar_u1(su) + pd => c1 + pu => pd + if(.not.associated(pu)) stop 122 + if(.not.associated(pu, c1)) stop 123 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=1) stop 124 + if(any(pu/=c1)) stop 125 + class default + stop 126 + end select + call achar_u1(pu) + ! + sd => cm(n) + su => sd + if(.not.associated(su)) stop 127 + if(.not.associated(su, cm(n))) stop 128 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 129 + if(su/=cm(n)) stop 130 + class default + stop 131 + end select + call schar_um(su) + pd => cm + su => pd(n) + if(.not.associated(su)) stop 132 + if(.not.associated(su, cm(n))) stop 133 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 134 + if(su/=cm(n)) stop 135 + class default + stop 136 + end select + call schar_um(su) + pd => cm + pu => pd + if(.not.associated(pu)) stop 137 + if(.not.associated(pu, cm)) stop 138 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=m) stop 139 + if(any(pu/=cm)) stop 140 + class default + stop 141 + end select + call achar_um(pu) + ! + sd => cm(n)(l:u) + su => sd + if(.not.associated(su)) stop 142 + if(.not.associated(su, cm(n)(l:u))) stop 143 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 144 + if(su/=cm(n)(l:u)) stop 145 + class default + stop 146 + end select + call schar_ue(su) + pd => cm(:)(l:u) + su => pd(n) + if(.not.associated(su)) stop 147 + if(.not.associated(su, cm(n)(l:u))) stop 148 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 149 + if(su/=cm(n)(l:u)) stop 150 + class default + stop 151 + end select + call schar_ue(su) + pd => cm(:)(l:u) + pu => pd + if(.not.associated(pu)) stop 152 + if(.not.associated(pu, cm(:)(l:u))) stop 153 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 154 + if(any(pu/=cm(:)(l:u))) stop 155 + class default + stop 156 + end select + call achar_ue(pu) + ! + sd => cm(n) + su => sd(l:u) + if(.not.associated(su)) stop 157 + if(.not.associated(su, cm(n)(l:u))) stop 158 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 159 + if(su/=cm(n)(l:u)) stop 160 + class default + stop 161 + end select + call schar_ue(su) + pd => cm(:) + su => pd(n)(l:u) + if(.not.associated(su)) stop 162 + if(.not.associated(su, cm(n)(l:u))) stop 163 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 164 + if(su/=cm(n)(l:u)) stop 165 + class default + stop 166 + end select + call schar_ue(su) + pd => cm + pu => pd(:)(l:u) + if(.not.associated(pu)) stop 167 + if(.not.associated(pu, cm(:)(l:u))) stop 168 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 169 + if(any(pu/=cm(:)(l:u))) stop 170 + class default + stop 171 + end select + call achar_ue(pu) + ! + stop + +contains + + subroutine schar_c1(a) + character(kind=k), pointer, intent(in) :: a + + if(.not.associated(a)) stop 172 + if(.not.associated(a, c1(n))) stop 173 + if(len(a)/=1) stop 174 + if(a/=c1(n)) stop 175 + return + end subroutine schar_c1 + + subroutine achar_c1(a) + character(kind=k), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 176 + if(.not.associated(a, c1)) stop 177 + if(len(a)/=1) stop 178 + if(any(a/=c1)) stop 179 + return + end subroutine achar_c1 + + subroutine schar_cm(a) + character(kind=k, len=m), pointer, intent(in) :: a + + if(.not.associated(a)) stop 180 + if(.not.associated(a, cm(n))) stop 181 + if(len(a)/=m) stop 182 + if(a/=cm(n)) stop 183 + return + end subroutine schar_cm + + subroutine achar_cm(a) + character(kind=k, len=m), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 184 + if(.not.associated(a, cm)) stop 185 + if(len(a)/=m) stop 186 + if(any(a/=cm)) stop 187 + return + end subroutine achar_cm + + subroutine schar_ce(a) + character(kind=k, len=e), pointer, intent(in) :: a + + if(.not.associated(a)) stop 188 + if(.not.associated(a, cm(n)(l:u))) stop 189 + if(len(a)/=e) stop 190 + if(a/=cm(n)(l:u)) stop 191 + return + end subroutine schar_ce + + subroutine achar_ce(a) + character(kind=k, len=e), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 192 + if(.not.associated(a, cm(:)(l:u))) stop 193 + if(len(a)/=e) stop 194 + if(any(a/=cm(:)(l:u))) stop 195 + return + end subroutine achar_ce + + subroutine schar_a1(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 196 + if(.not.associated(a, c1(n))) stop 197 + if(len(a)/=1) stop 198 + if(a/=c1(n)) stop 199 + return + end subroutine schar_a1 + + subroutine achar_a1(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 200 + if(.not.associated(a, c1)) stop 201 + if(len(a)/=1) stop 202 + if(any(a/=c1)) stop 203 + return + end subroutine achar_a1 + + subroutine schar_am(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 204 + if(.not.associated(a, cm(n))) stop 205 + if(len(a)/=m) stop 206 + if(a/=cm(n)) stop 207 + return + end subroutine schar_am + + subroutine achar_am(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 208 + if(.not.associated(a, cm)) stop 209 + if(len(a)/=m) stop 210 + if(any(a/=cm)) stop 211 + return + end subroutine achar_am + + subroutine schar_ae(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 212 + if(.not.associated(a, cm(n)(l:u))) stop 213 + if(len(a)/=e) stop 214 + if(a/=cm(n)(l:u)) stop 215 + return + end subroutine schar_ae + + subroutine achar_ae(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 216 + if(.not.associated(a, cm(:)(l:u))) stop 217 + if(len(a)/=e) stop 218 + if(any(a/=cm(:)(l:u))) stop 219 + return + end subroutine achar_ae + + subroutine schar_d1(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 220 + if(.not.associated(a, c1(n))) stop 221 + if(len(a)/=1) stop 222 + if(a/=c1(n)) stop 223 + return + end subroutine schar_d1 + + subroutine achar_d1(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 224 + if(.not.associated(a, c1)) stop 225 + if(len(a)/=1) stop 226 + if(any(a/=c1)) stop 227 + return + end subroutine achar_d1 + + subroutine schar_dm(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 228 + if(.not.associated(a, cm(n))) stop 229 + if(len(a)/=m) stop 230 + if(a/=cm(n)) stop 231 + return + end subroutine schar_dm + + subroutine achar_dm(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 232 + if(.not.associated(a, cm)) stop 233 + if(len(a)/=m) stop 234 + if(any(a/=cm)) stop 235 + return + end subroutine achar_dm + + subroutine schar_de(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 236 + if(.not.associated(a, cm(n)(l:u))) stop 237 + if(len(a)/=e) stop 238 + if(a/=cm(n)(l:u)) stop 239 + return + end subroutine schar_de + + subroutine achar_de(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 240 + if(.not.associated(a, cm(:)(l:u))) stop 241 + if(len(a)/=e) stop 242 + if(any(a/=cm(:)(l:u))) stop 243 + return + end subroutine achar_de + + subroutine schar_u1(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 244 + if(.not.associated(a, c1(n))) stop 245 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=1) stop 246 + if(a/=c1(n)) stop 247 + class default + stop 248 + end select + return + end subroutine schar_u1 + + subroutine achar_u1(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 249 + if(.not.associated(a, c1)) stop 250 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=1) stop 251 + if(any(a/=c1)) stop 252 + class default + stop 253 + end select + return + end subroutine achar_u1 + + subroutine schar_um(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 254 + if(.not.associated(a)) stop 255 + if(.not.associated(a, cm(n))) stop 256 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=m) stop 257 + if(a/=cm(n)) stop 258 + class default + stop 259 + end select + return + end subroutine schar_um + + subroutine achar_um(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 260 + if(.not.associated(a, cm)) stop 261 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=m) stop 262 + if(any(a/=cm)) stop 263 + class default + stop 264 + end select + return + end subroutine achar_um + + subroutine schar_ue(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 265 + if(.not.associated(a, cm(n)(l:u))) stop 266 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=e) stop 267 + if(a/=cm(n)(l:u)) stop 268 + class default + stop 269 + end select + return + end subroutine schar_ue + + subroutine achar_ue(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 270 + if(.not.associated(a, cm(:)(l:u))) stop 271 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=e) stop 272 + if(any(a/=cm(:)(l:u))) stop 273 + class default + stop 274 + end select + return + end subroutine achar_ue + +end program main_p diff --git a/gcc/testsuite/gfortran.dg/character_workout_4.f90 b/gcc/testsuite/gfortran.dg/character_workout_4.f90 new file mode 100644 index 00000000000..993c742c76c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/character_workout_4.f90 @@ -0,0 +1,689 @@ +! { dg-do run } +! +! Tests fix for PR100120/100816/100818/100819/100821 +! + +program main_p + + implicit none + + integer, parameter :: k = 4 + integer, parameter :: n = 11 + integer, parameter :: m = 7 + integer, parameter :: l = 3 + integer, parameter :: u = 5 + integer, parameter :: e = u-l+1 + integer, parameter :: c = int(z"FF00") + + character(kind=k), target :: c1(n) + character(len=m, kind=k), target :: cm(n) + ! + character(kind=k), pointer :: s1 + character(len=m, kind=k), pointer :: sm + character(len=e, kind=k), pointer :: se + character(len=:, kind=k), pointer :: sd + ! + character(kind=k), pointer :: p1(:) + character(len=m, kind=k), pointer :: pm(:) + character(len=e, kind=k), pointer :: pe(:) + character(len=:, kind=k), pointer :: pd(:) + + class(*), pointer :: su + class(*), pointer :: pu(:) + + integer :: i, j + + nullify(s1, sm, se, sd, su) + nullify(p1, pm, pe, pd, pu) + c1 = [(char(i+c, kind=k), i=1,n)] + do i = 1, n + do j = 1, m + cm(i)(j:j) = char(i*m+j+c-m, kind=k) + end do + end do + + s1 => c1(n) + if(.not.associated(s1)) stop 1 + if(.not.associated(s1, c1(n))) stop 2 + if(len(s1)/=1) stop 3 + if(s1/=c1(n)) stop 4 + call schar_c1(s1) + call schar_a1(s1) + p1 => c1 + if(.not.associated(p1)) stop 5 + if(.not.associated(p1, c1)) stop 6 + if(len(p1)/=1) stop 7 + if(any(p1/=c1)) stop 8 + call achar_c1(p1) + call achar_a1(p1) + ! + sm => cm(n) + if(.not.associated(sm)) stop 9 + if(.not.associated(sm, cm(n))) stop 10 + if(len(sm)/=m) stop 11 + if(sm/=cm(n)) stop 12 + call schar_cm(sm) + call schar_am(sm) + pm => cm + if(.not.associated(pm)) stop 13 + if(.not.associated(pm, cm)) stop 14 + if(len(pm)/=m) stop 15 + if(any(pm/=cm)) stop 16 + call achar_cm(pm) + call achar_am(pm) + ! + se => cm(n)(l:u) + if(.not.associated(se)) stop 17 + if(.not.associated(se, cm(n)(l:u))) stop 18 + if(len(se)/=e) stop 19 + if(se/=cm(n)(l:u)) stop 20 + call schar_ce(se) + call schar_ae(se) + pe => cm(:)(l:u) + if(.not.associated(pe)) stop 21 + if(.not.associated(pe, cm(:)(l:u))) stop 22 + if(len(pe)/=e) stop 23 + if(any(pe/=cm(:)(l:u))) stop 24 + call achar_ce(pe) + call achar_ae(pe) + ! + sd => c1(n) + if(.not.associated(sd)) stop 25 + if(.not.associated(sd, c1(n))) stop 26 + if(len(sd)/=1) stop 27 + if(sd/=c1(n)) stop 28 + call schar_d1(sd) + pd => c1 + if(.not.associated(pd)) stop 29 + if(.not.associated(pd, c1)) stop 30 + if(len(pd)/=1) stop 31 + if(any(pd/=c1)) stop 32 + call achar_d1(pd) + ! + sd => cm(n) + if(.not.associated(sd)) stop 33 + if(.not.associated(sd, cm(n))) stop 34 + if(len(sd)/=m) stop 35 + if(sd/=cm(n)) stop 36 + call schar_dm(sd) + pd => cm + if(.not.associated(pd)) stop 37 + if(.not.associated(pd, cm)) stop 38 + if(len(pd)/=m) stop 39 + if(any(pd/=cm)) stop 40 + call achar_dm(pd) + ! + sd => cm(n)(l:u) + if(.not.associated(sd)) stop 41 + if(.not.associated(sd, cm(n)(l:u))) stop 42 + if(len(sd)/=e) stop 43 + if(sd/=cm(n)(l:u)) stop 44 + call schar_de(sd) + pd => cm(:)(l:u) + if(.not.associated(pd)) stop 45 + if(.not.associated(pd, cm(:)(l:u))) stop 46 + if(len(pd)/=e) stop 47 + if(any(pd/=cm(:)(l:u))) stop 48 + call achar_de(pd) + ! + sd => c1(n) + s1 => sd + if(.not.associated(s1)) stop 49 + if(.not.associated(s1, c1(n))) stop 50 + if(len(s1)/=1) stop 51 + if(s1/=c1(n)) stop 52 + call schar_c1(s1) + call schar_a1(s1) + pd => c1 + s1 => pd(n) + if(.not.associated(s1)) stop 53 + if(.not.associated(s1, c1(n))) stop 54 + if(len(s1)/=1) stop 55 + if(s1/=c1(n)) stop 56 + call schar_c1(s1) + call schar_a1(s1) + pd => c1 + p1 => pd + if(.not.associated(p1)) stop 57 + if(.not.associated(p1, c1)) stop 58 + if(len(p1)/=1) stop 59 + if(any(p1/=c1)) stop 60 + call achar_c1(p1) + call achar_a1(p1) + ! + sd => cm(n) + sm => sd + if(.not.associated(sm)) stop 61 + if(.not.associated(sm, cm(n))) stop 62 + if(len(sm)/=m) stop 63 + if(sm/=cm(n)) stop 64 + call schar_cm(sm) + call schar_am(sm) + pd => cm + sm => pd(n) + if(.not.associated(sm)) stop 65 + if(.not.associated(sm, cm(n))) stop 66 + if(len(sm)/=m) stop 67 + if(sm/=cm(n)) stop 68 + call schar_cm(sm) + call schar_am(sm) + pd => cm + pm => pd + if(.not.associated(pm)) stop 69 + if(.not.associated(pm, cm)) stop 70 + if(len(pm)/=m) stop 71 + if(any(pm/=cm)) stop 72 + call achar_cm(pm) + call achar_am(pm) + ! + sd => cm(n)(l:u) + se => sd + if(.not.associated(se)) stop 73 + if(.not.associated(se, cm(n)(l:u))) stop 74 + if(len(se)/=e) stop 75 + if(se/=cm(n)(l:u)) stop 76 + call schar_ce(se) + call schar_ae(se) + pd => cm(:)(l:u) + pe => pd + if(.not.associated(pe)) stop 77 + if(.not.associated(pe, cm(:)(l:u))) stop 78 + if(len(pe)/=e) stop 79 + if(any(pe/=cm(:)(l:u))) stop 80 + call achar_ce(pe) + call achar_ae(pe) + ! + su => c1(n) + if(.not.associated(su)) stop 81 + if(.not.associated(su, c1(n))) stop 82 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 83 + if(su/=c1(n)) stop 84 + class default + stop 85 + end select + call schar_u1(su) + pu => c1 + if(.not.associated(pu)) stop 86 + if(.not.associated(pu, c1)) stop 87 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=1) stop 88 + if(any(pu/=c1)) stop 89 + class default + stop 90 + end select + call achar_u1(pu) + ! + su => cm(n) + if(.not.associated(su)) stop 91 + if(.not.associated(su)) stop 92 + if(.not.associated(su, cm(n))) stop 93 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 94 + if(su/=cm(n)) stop 95 + class default + stop 96 + end select + call schar_um(su) + pu => cm + if(.not.associated(pu)) stop 97 + if(.not.associated(pu, cm)) stop 98 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=m) stop 99 + if(any(pu/=cm)) stop 100 + class default + stop 101 + end select + call achar_um(pu) + ! + su => cm(n)(l:u) + if(.not.associated(su)) stop 102 + if(.not.associated(su, cm(n)(l:u))) stop 103 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 104 + if(su/=cm(n)(l:u)) stop 105 + class default + stop 106 + end select + call schar_ue(su) + pu => cm(:)(l:u) + if(.not.associated(pu)) stop 107 + if(.not.associated(pu, cm(:)(l:u))) stop 108 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 109 + if(any(pu/=cm(:)(l:u))) stop 110 + class default + stop 111 + end select + call achar_ue(pu) + ! + sd => c1(n) + su => sd + if(.not.associated(su)) stop 112 + if(.not.associated(su, c1(n))) stop 113 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 114 + if(su/=c1(n)) stop 115 + class default + stop 116 + end select + call schar_u1(su) + pd => c1 + su => pd(n) + if(.not.associated(su)) stop 117 + if(.not.associated(su, c1(n))) stop 118 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 119 + if(su/=c1(n)) stop 120 + class default + stop 121 + end select + call schar_u1(su) + pd => c1 + pu => pd + if(.not.associated(pu)) stop 122 + if(.not.associated(pu, c1)) stop 123 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=1) stop 124 + if(any(pu/=c1)) stop 125 + class default + stop 126 + end select + call achar_u1(pu) + ! + sd => cm(n) + su => sd + if(.not.associated(su)) stop 127 + if(.not.associated(su, cm(n))) stop 128 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 129 + if(su/=cm(n)) stop 130 + class default + stop 131 + end select + call schar_um(su) + pd => cm + su => pd(n) + if(.not.associated(su)) stop 132 + if(.not.associated(su, cm(n))) stop 133 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 134 + if(su/=cm(n)) stop 135 + class default + stop 136 + end select + call schar_um(su) + pd => cm + pu => pd + if(.not.associated(pu)) stop 137 + if(.not.associated(pu, cm)) stop 138 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=m) stop 139 + if(any(pu/=cm)) stop 140 + class default + stop 141 + end select + call achar_um(pu) + ! + sd => cm(n)(l:u) + su => sd + if(.not.associated(su)) stop 142 + if(.not.associated(su, cm(n)(l:u))) stop 143 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 144 + if(su/=cm(n)(l:u)) stop 145 + class default + stop 146 + end select + call schar_ue(su) + pd => cm(:)(l:u) + su => pd(n) + if(.not.associated(su)) stop 147 + if(.not.associated(su, cm(n)(l:u))) stop 148 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 149 + if(su/=cm(n)(l:u)) stop 150 + class default + stop 151 + end select + call schar_ue(su) + pd => cm(:)(l:u) + pu => pd + if(.not.associated(pu)) stop 152 + if(.not.associated(pu, cm(:)(l:u))) stop 153 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 154 + if(any(pu/=cm(:)(l:u))) stop 155 + class default + stop 156 + end select + call achar_ue(pu) + ! + sd => cm(n) + su => sd(l:u) + if(.not.associated(su)) stop 157 + if(.not.associated(su, cm(n)(l:u))) stop 158 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 159 + if(su/=cm(n)(l:u)) stop 160 + class default + stop 161 + end select + call schar_ue(su) + pd => cm(:) + su => pd(n)(l:u) + if(.not.associated(su)) stop 162 + if(.not.associated(su, cm(n)(l:u))) stop 163 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 164 + if(su/=cm(n)(l:u)) stop 165 + class default + stop 166 + end select + call schar_ue(su) + pd => cm + pu => pd(:)(l:u) + if(.not.associated(pu)) stop 167 + if(.not.associated(pu, cm(:)(l:u))) stop 168 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 169 + if(any(pu/=cm(:)(l:u))) stop 170 + class default + stop 171 + end select + call achar_ue(pu) + ! + stop + +contains + + subroutine schar_c1(a) + character(kind=k), pointer, intent(in) :: a + + if(.not.associated(a)) stop 172 + if(.not.associated(a, c1(n))) stop 173 + if(len(a)/=1) stop 174 + if(a/=c1(n)) stop 175 + return + end subroutine schar_c1 + + subroutine achar_c1(a) + character(kind=k), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 176 + if(.not.associated(a, c1)) stop 177 + if(len(a)/=1) stop 178 + if(any(a/=c1)) stop 179 + return + end subroutine achar_c1 + + subroutine schar_cm(a) + character(kind=k, len=m), pointer, intent(in) :: a + + if(.not.associated(a)) stop 180 + if(.not.associated(a, cm(n))) stop 181 + if(len(a)/=m) stop 182 + if(a/=cm(n)) stop 183 + return + end subroutine schar_cm + + subroutine achar_cm(a) + character(kind=k, len=m), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 184 + if(.not.associated(a, cm)) stop 185 + if(len(a)/=m) stop 186 + if(any(a/=cm)) stop 187 + return + end subroutine achar_cm + + subroutine schar_ce(a) + character(kind=k, len=e), pointer, intent(in) :: a + + if(.not.associated(a)) stop 188 + if(.not.associated(a, cm(n)(l:u))) stop 189 + if(len(a)/=e) stop 190 + if(a/=cm(n)(l:u)) stop 191 + return + end subroutine schar_ce + + subroutine achar_ce(a) + character(kind=k, len=e), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 192 + if(.not.associated(a, cm(:)(l:u))) stop 193 + if(len(a)/=e) stop 194 + if(any(a/=cm(:)(l:u))) stop 195 + return + end subroutine achar_ce + + subroutine schar_a1(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 196 + if(.not.associated(a, c1(n))) stop 197 + if(len(a)/=1) stop 198 + if(a/=c1(n)) stop 199 + return + end subroutine schar_a1 + + subroutine achar_a1(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 200 + if(.not.associated(a, c1)) stop 201 + if(len(a)/=1) stop 202 + if(any(a/=c1)) stop 203 + return + end subroutine achar_a1 + + subroutine schar_am(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 204 + if(.not.associated(a, cm(n))) stop 205 + if(len(a)/=m) stop 206 + if(a/=cm(n)) stop 207 + return + end subroutine schar_am + + subroutine achar_am(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 208 + if(.not.associated(a, cm)) stop 209 + if(len(a)/=m) stop 210 + if(any(a/=cm)) stop 211 + return + end subroutine achar_am + + subroutine schar_ae(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 212 + if(.not.associated(a, cm(n)(l:u))) stop 213 + if(len(a)/=e) stop 214 + if(a/=cm(n)(l:u)) stop 215 + return + end subroutine schar_ae + + subroutine achar_ae(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 216 + if(.not.associated(a, cm(:)(l:u))) stop 217 + if(len(a)/=e) stop 218 + if(any(a/=cm(:)(l:u))) stop 219 + return + end subroutine achar_ae + + subroutine schar_d1(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 220 + if(.not.associated(a, c1(n))) stop 221 + if(len(a)/=1) stop 222 + if(a/=c1(n)) stop 223 + return + end subroutine schar_d1 + + subroutine achar_d1(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 224 + if(.not.associated(a, c1)) stop 225 + if(len(a)/=1) stop 226 + if(any(a/=c1)) stop 227 + return + end subroutine achar_d1 + + subroutine schar_dm(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 228 + if(.not.associated(a, cm(n))) stop 229 + if(len(a)/=m) stop 230 + if(a/=cm(n)) stop 231 + return + end subroutine schar_dm + + subroutine achar_dm(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 232 + if(.not.associated(a, cm)) stop 233 + if(len(a)/=m) stop 234 + if(any(a/=cm)) stop 235 + return + end subroutine achar_dm + + subroutine schar_de(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 236 + if(.not.associated(a, cm(n)(l:u))) stop 237 + if(len(a)/=e) stop 238 + if(a/=cm(n)(l:u)) stop 239 + return + end subroutine schar_de + + subroutine achar_de(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 240 + if(.not.associated(a, cm(:)(l:u))) stop 241 + if(len(a)/=e) stop 242 + if(any(a/=cm(:)(l:u))) stop 243 + return + end subroutine achar_de + + subroutine schar_u1(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 244 + if(.not.associated(a, c1(n))) stop 245 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=1) stop 246 + if(a/=c1(n)) stop 247 + class default + stop 248 + end select + return + end subroutine schar_u1 + + subroutine achar_u1(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 249 + if(.not.associated(a, c1)) stop 250 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=1) stop 251 + if(any(a/=c1)) stop 252 + class default + stop 253 + end select + return + end subroutine achar_u1 + + subroutine schar_um(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 254 + if(.not.associated(a)) stop 255 + if(.not.associated(a, cm(n))) stop 256 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=m) stop 257 + if(a/=cm(n)) stop 258 + class default + stop 259 + end select + return + end subroutine schar_um + + subroutine achar_um(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 260 + if(.not.associated(a, cm)) stop 261 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=m) stop 262 + if(any(a/=cm)) stop 263 + class default + stop 264 + end select + return + end subroutine achar_um + + subroutine schar_ue(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 265 + if(.not.associated(a, cm(n)(l:u))) stop 266 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=e) stop 267 + if(a/=cm(n)(l:u)) stop 268 + class default + stop 269 + end select + return + end subroutine schar_ue + + subroutine achar_ue(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 270 + if(.not.associated(a, cm(:)(l:u))) stop 271 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=e) stop 272 + if(any(a/=cm(:)(l:u))) stop 273 + class default + stop 274 + end select + return + end subroutine achar_ue + +end program main_p diff --git a/libgfortran/intrinsics/associated.c b/libgfortran/intrinsics/associated.c index 9a4d6b19431..943fc69ed47 100644 --- a/libgfortran/intrinsics/associated.c +++ b/libgfortran/intrinsics/associated.c @@ -37,7 +37,7 @@ associated (const gfc_array_void *pointer, const gfc_array_void *target) return 0; if (GFC_DESCRIPTOR_DATA (pointer) != GFC_DESCRIPTOR_DATA (target)) return 0; - if (GFC_DESCRIPTOR_DTYPE (pointer).elem_len != GFC_DESCRIPTOR_DTYPE (target).elem_len) + if (GFC_DESCRIPTOR_SPAN (pointer) != GFC_DESCRIPTOR_SPAN (target)) return 0; if (GFC_DESCRIPTOR_DTYPE (pointer).type != GFC_DESCRIPTOR_DTYPE (target).type) return 0; diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 1e92f1a50d3..285c36a00b5 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -409,6 +409,7 @@ typedef GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_INTEGER_4) gfc_full_a #define GFC_DESCRIPTOR_SIZE(desc) ((desc)->dtype.elem_len) #define GFC_DESCRIPTOR_DATA(desc) ((desc)->base_addr) #define GFC_DESCRIPTOR_DTYPE(desc) ((desc)->dtype) +#define GFC_DESCRIPTOR_SPAN(desc) ((desc)->span) #define GFC_DIMENSION_LBOUND(dim) ((dim).lower_bound) #define GFC_DIMENSION_UBOUND(dim) ((dim)._ubound)