aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/trans-array.c61
-rw-r--r--gcc/fortran/trans-expr.c70
-rw-r--r--gcc/fortran/trans-intrinsic.c1
-rw-r--r--gcc/fortran/trans-types.c68
-rw-r--r--gcc/fortran/trans-types.h2
-rw-r--r--gcc/fortran/trans.c26
-rw-r--r--gcc/fortran/trans.h5
-rw-r--r--gcc/testsuite/gfortran.dg/PR100120.f90198
-rw-r--r--gcc/testsuite/gfortran.dg/character_workout_1.f90689
-rw-r--r--gcc/testsuite/gfortran.dg/character_workout_4.f90689
10 files changed, 1730 insertions, 79 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 7eeef55..a6bcd2b 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 00690fe..e3bc886 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 98fa28d..73b0bcc 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 9f21b3e..5582e40 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<constructor_elt, va_gc> *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 ff01226..3b45ce2 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 3ffa394..f26e91b 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 69d3fdc..d1d4a1d 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 0000000..c1e6c99
--- /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 0000000..98133b4
--- /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 0000000..993c742
--- /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
generated by cgit v1.1 at 2025-05-28 14:29:27 +0000