FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Fix some issues with pointers to character.

Browse source 
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.
This commit is contained in:
José Rui Faustino de Sousa 2021-06-05 11:12:50 +00:00
parent 96963713f6
commit d514626ee2
12 changed files with 1731 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

59
gcc/fortran/trans-array.c
View file

@ -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 (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (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;
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;

70
gcc/fortran/trans-expr.c
View file

@ -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)

1
gcc/fortran/trans-intrinsic.c
View file

@ -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);

68
gcc/fortran/trans-types.c
View file

@ -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)

2
gcc/fortran/trans-types.h
View file

@ -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);

26
gcc/fortran/trans.c
View file

@ -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

5
gcc/fortran/trans.h
View file

@ -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);

198
gcc/testsuite/gfortran.dg/PR100120.f90 Normal file
View file

@ -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

689
gcc/testsuite/gfortran.dg/character_workout_1.f90 Normal file
View file

@ -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

689
gcc/testsuite/gfortran.dg/character_workout_4.f90 Normal file
View file

@ -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

2
libgfortran/intrinsics/associated.c
View file

@ -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;

1
libgfortran/libgfortran.h
View file

@ -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)