mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-02 06:40:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr))

Browse Source 
2010-08-17  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	* gfortran.h (struct gfc_association_list): New member `where'.
	(gfc_is_associate_pointer) New method.
	* match.c (gfc_match_associate): Remember locus for each associate
	name matched and do not try to set variable flag.
	* parse.c (parse_associate): Use remembered locus for symbols.
	* primary.c (match_variable): Instead of variable-flag check for
	associate names set it for all such names used.
	* symbol.c (gfc_is_associate_pointer): New method.
	* resolve.c (resolve_block_construct): Don't generate assignments
	to give associate-names their values.
	(resolve_fl_var_and_proc): Allow associate-names to be deferred-shape.
	(resolve_symbol): Set some more attributes for associate variables,
	set variable flag here and check it and don't try to build an
	explicitely shaped array-spec for array associate variables.
	* trans-expr.c (gfc_conv_variable): Dereference in case of association
	to scalar variable.
	* trans-types.c (gfc_is_nodesc_array): Handle array association symbols.
	(gfc_sym_type): Return pointer type for association to scalar vars.
	* trans-decl.c (gfc_get_symbol_decl): Defer association symbols.
	(trans_associate_var): New method.
	(gfc_trans_deferred_vars): Handle association symbols.

2010-08-17  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	* gfortran.dg/associate_1.f03: Extended to test newly supported
	features like association to variables.
	* gfortran.dg/associate_3.f03: Removed check for illegal change
	of associate-name here...
	* gfortran.dg/associate_5.f03: ...and added it here.
	* gfortran.dg/associate_6.f03: No longer XFAIL'ed.
	* gfortran.dg/associate_7.f03: New test.

From-SVN: r163295
This commit is contained in:
Daniel Kraft 2010-08-17 10:20:03 +02:00 committed by Daniel Kraft
parent 3373692b59
commit 571d54deb6
16 changed files with 346 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/fortran/ChangeLog
View File

@ -1,3 +1,28 @@
2010-08-17 Daniel Kraft <d@domob.eu>
PR fortran/38936
* gfortran.h (struct gfc_association_list): New member `where'.
(gfc_is_associate_pointer) New method.
* match.c (gfc_match_associate): Remember locus for each associate
name matched and do not try to set variable flag.
* parse.c (parse_associate): Use remembered locus for symbols.
* primary.c (match_variable): Instead of variable-flag check for
associate names set it for all such names used.
* symbol.c (gfc_is_associate_pointer): New method.
* resolve.c (resolve_block_construct): Don't generate assignments
to give associate-names their values.
(resolve_fl_var_and_proc): Allow associate-names to be deferred-shape.
(resolve_symbol): Set some more attributes for associate variables,
set variable flag here and check it and don't try to build an
explicitely shaped array-spec for array associate variables.
* trans-expr.c (gfc_conv_variable): Dereference in case of association
to scalar variable.
* trans-types.c (gfc_is_nodesc_array): Handle array association symbols.
(gfc_sym_type): Return pointer type for association to scalar vars.
* trans-decl.c (gfc_get_symbol_decl): Defer association symbols.
(trans_associate_var): New method.
(gfc_trans_deferred_vars): Handle association symbols.
2010-08-16 Joseph Myers <joseph@codesourcery.com>
* lang.opt (MDX): Change back to MD. Mark NoDriverArg instead of

4
gcc/fortran/gfortran.h
View File

@ -2007,6 +2007,8 @@ typedef struct gfc_association_list
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *st; /* Symtree corresponding to name. */
locus where;
gfc_expr *target;
}
gfc_association_list;
@ -2579,6 +2581,8 @@ void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
bool gfc_is_associate_pointer (gfc_symbol*);
/* intrinsic.c -- true if working in an init-expr, false otherwise. */
extern bool gfc_init_expr_flag;

10
gcc/fortran/match.c
View File

@ -1827,6 +1827,7 @@ gfc_match_associate (void)
gfc_error ("Expected association at %C");
goto assocListError;
}
newAssoc->where = gfc_current_locus;
/* Check that the current name is not yet in the list. */
for (a = new_st.ext.block.assoc; a; a = a->next)
@ -1844,10 +1845,11 @@ gfc_match_associate (void)
goto assocListError;
}
/* The target is a variable (and may be used as lvalue) if it's an
EXPR_VARIABLE and does not have vector-subscripts. */
newAssoc->variable = (newAssoc->target->expr_type == EXPR_VARIABLE
&& !gfc_has_vector_subscript (newAssoc->target));
/* The `variable' field is left blank for now; because the target is not
yet resolved, we can't use gfc_has_vector_subscript to determine it
for now. Instead, if the symbol is matched as variable, this field
is set -- and during resolution we check that. */
newAssoc->variable = 0;
/* Put it into the list. */
newAssoc->next = new_st.ext.block.assoc;

18
gcc/fortran/parse.c
View File

@ -3215,23 +3215,21 @@ parse_associate (void)
new_st.ext.block.ns = my_ns;
gcc_assert (new_st.ext.block.assoc);
/* Add all associate-names as BLOCK variables. There values will be assigned
to them during resolution of the ASSOCIATE construct. */
/* Add all associate-names as BLOCK variables. Creating them is enough
for now, they'll get their values during trans-* phase. */
gfc_current_ns = my_ns;
for (a = new_st.ext.block.assoc; a; a = a->next)
{
if (a->variable)
{
gfc_error ("Association to variables is not yet supported at %C");
return;
}
gfc_symbol* sym;
if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
gcc_unreachable ();
a->st->n.sym->attr.flavor = FL_VARIABLE;
a->st->n.sym->assoc = a;
gfc_set_sym_referenced (a->st->n.sym);
sym = a->st->n.sym;
sym->attr.flavor = FL_VARIABLE;
sym->assoc = a;
sym->declared_at = a->where;
gfc_set_sym_referenced (sym);
}
accept_statement (ST_ASSOCIATE);

8
gcc/fortran/primary.c
View File

@ -2982,12 +2982,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
gfc_error ("Assigning to PROTECTED variable at %C");
return MATCH_ERROR;
}
if (sym->assoc && !sym->assoc->variable)
{
gfc_error ("'%s' associated to expression can't appear in a variable"
" definition context at %C", sym->name);
return MATCH_ERROR;
}
if (sym->assoc)
sym->assoc->variable = 1;
break;
case FL_UNKNOWN:

114
gcc/fortran/resolve.c
View File

@ -8295,39 +8295,7 @@ resolve_block_construct (gfc_code* code)
gfc_resolve (code->ext.block.ns);
/* For an ASSOCIATE block, the associations (and their targets) are already
resolved during gfc_resolve_symbol. Here, we have to add code
to assign expression values to the variables associated to expressions. */
if (code->ext.block.assoc)
{
gfc_association_list* a;
gfc_code* assignTail;
gfc_code* assignHead;
assignHead = assignTail = NULL;
for (a = code->ext.block.assoc; a; a = a->next)
if (!a->variable)
{
gfc_code* newAssign;
newAssign = gfc_get_code ();
newAssign->op = EXEC_ASSIGN;
newAssign->loc = gfc_current_locus;
newAssign->expr1 = gfc_lval_expr_from_sym (a->st->n.sym);
newAssign->expr2 = a->target;
if (!assignHead)
assignHead = newAssign;
else
{
gcc_assert (assignTail);
assignTail->next = newAssign;
}
assignTail = newAssign;
}
assignTail->next = code->ext.block.ns->code;
code->ext.block.ns->code = assignHead;
}
resolved during gfc_resolve_symbol. */
}
@ -9523,12 +9491,11 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
sym->name, &sym->declared_at);
return FAILURE;
}
}
else
{
if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
&& !sym->attr.dummy && sym->ts.type != BT_CLASS)
&& !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
@ -11692,59 +11659,70 @@ resolve_symbol (gfc_symbol *sym)
they get their type-spec set this way. */
if (sym->assoc)
{
gfc_expr* target;
bool to_var;
gcc_assert (sym->attr.flavor == FL_VARIABLE);
if (gfc_resolve_expr (sym->assoc->target) != SUCCESS)
target = sym->assoc->target;
if (gfc_resolve_expr (target) != SUCCESS)
return;
sym->ts = sym->assoc->target->ts;
/* For variable targets, we get some attributes from the target. */
if (target->expr_type == EXPR_VARIABLE)
{
gfc_symbol* tsym;
gcc_assert (target->symtree);
tsym = target->symtree->n.sym;
sym->attr.asynchronous = tsym->attr.asynchronous;
sym->attr.volatile_ = tsym->attr.volatile_;
sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
}
sym->ts = target->ts;
gcc_assert (sym->ts.type != BT_UNKNOWN);
if (sym->attr.dimension && sym->assoc->target->rank == 0)
/* See if this is a valid association-to-variable. */
to_var = (target->expr_type == EXPR_VARIABLE
&& !gfc_has_vector_subscript (target));
if (sym->assoc->variable && !to_var)
{
if (target->expr_type == EXPR_VARIABLE)
gfc_error ("'%s' at %L associated to vector-indexed target can not"
" be used in a variable definition context",
sym->name, &sym->declared_at);
else
gfc_error ("'%s' at %L associated to expression can not"
" be used in a variable definition context",
sym->name, &sym->declared_at);
return;
}
sym->assoc->variable = to_var;
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)
{
gfc_error ("Associate-name '%s' at %L is used as array",
sym->name, &sym->declared_at);
sym->attr.dimension = 0;
return;
}
if (sym->assoc->target->rank > 0)
if (target->rank > 0)
sym->attr.dimension = 1;
if (sym->attr.dimension)
{
int dim;
sym->as = gfc_get_array_spec ();
sym->as->rank = sym->assoc->target->rank;
sym->as->type = AS_EXPLICIT;
sym->as->rank = target->rank;
sym->as->type = AS_DEFERRED;
/* Target must not be coindexed, thus the associate-variable
has no corank. */
sym->as->corank = 0;
for (dim = 0; dim < sym->assoc->target->rank; ++dim)
{
gfc_expr* dim_expr;
gfc_expr* e;
dim_expr = gfc_get_constant_expr (BT_INTEGER,
gfc_default_integer_kind,
&sym->declared_at);
mpz_set_si (dim_expr->value.integer, dim + 1);
e = gfc_build_intrinsic_call ("lbound", sym->declared_at, 3,
gfc_copy_expr (sym->assoc->target),
gfc_copy_expr (dim_expr), NULL);
gfc_resolve_expr (e);
sym->as->lower[dim] = e;
e = gfc_build_intrinsic_call ("ubound", sym->declared_at, 3,
gfc_copy_expr (sym->assoc->target),
gfc_copy_expr (dim_expr), NULL);
gfc_resolve_expr (e);
sym->as->upper[dim] = e;
gfc_free_expr (dim_expr);
}
}
}

20
gcc/fortran/symbol.c
View File

@ -4758,3 +4758,23 @@ gfc_find_proc_namespace (gfc_namespace* ns)
return ns;
}
/* Check if an associate-variable should be translated as an `implicit' pointer
internally (if it is associated to a variable and not an array with
descriptor). */
bool
gfc_is_associate_pointer (gfc_symbol* sym)
{
if (!sym->assoc)
return false;
if (!sym->assoc->variable)
return false;
if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
return false;
return true;
}

119
gcc/fortran/trans-decl.c
View File

@ -1206,7 +1206,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
}
/* Remember this variable for allocation/cleanup. */
if (sym->attr.dimension || sym->attr.allocatable
if (sym->attr.dimension || sym->attr.allocatable || sym->assoc
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable))
@ -3095,12 +3095,125 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
/* Do proper initialization for ASSOCIATE names. */
static void
trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
{
gfc_expr* e;
tree tmp;
gcc_assert (sym->assoc);
e = sym->assoc->target;
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating
to a variable. */
if (sym->attr.dimension
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
gfc_ss* ss;
tree desc;
desc = sym->backend_decl;
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
ss = gfc_walk_expr (e);
if (sym->assoc->variable)
{
se.direct_byref = 1;
se.expr = desc;
}
gfc_conv_expr_descriptor (&se, e, ss);
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
if (!sym->assoc->variable)
{
tree offs;
int dim;
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1 all the time.
The offset has to be corrected as well.
Because the ubound shift and offset depends on the lower bounds, we
first calculate those and set the lbound to one last. */
offs = gfc_conv_descriptor_offset_get (desc);
for (dim = 0; dim < e->rank; ++dim)
{
tree from, to;
tree stride;
from = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
to = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, from);
to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, tmp);
gfc_conv_descriptor_ubound_set (&se.pre, desc,
gfc_rank_cst[dim], to);
}
gfc_conv_descriptor_offset_set (&se.pre, desc, offs);
for (dim = 0; dim < e->rank; ++dim)
gfc_conv_descriptor_lbound_set (&se.pre, desc, gfc_rank_cst[dim],
gfc_index_one_node);
}
/* Done, register stuff as init / cleanup code. */
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
}
/* Do a scalar pointer assignment; this is for scalar variable targets. */
else if (gfc_is_associate_pointer (sym))
{
gfc_se se;
gcc_assert (!sym->attr.dimension);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, e);
tmp = TREE_TYPE (sym->backend_decl);
tmp = gfc_build_addr_expr (tmp, se.expr);
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
/* Do a simple assignment. This is for scalar expressions, where we
can simply use expression assignment. */
else
{
gfc_expr* lhs;
lhs = gfc_lval_expr_from_sym (sym);
tmp = gfc_trans_assignment (lhs, e, false, true);
gfc_add_init_cleanup (block, tmp, NULL_TREE);
}
}
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
Allocation of character string variables.
Initialization and possibly repacking of dummy arrays.
Initialization of ASSIGN statement auxiliary variable.
Initialization of ASSOCIATE names.
Automatic deallocation. */
void
@ -3159,7 +3272,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
{
bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
&& sym->ts.u.derived->attr.alloc_comp;
if (sym->attr.dimension)
if (sym->assoc)
trans_associate_var (sym, block);
else if (sym->attr.dimension)
{
switch (sym->as->type)
{

5
gcc/fortran/trans-expr.c
View File

@ -672,9 +672,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
/* Dereference non-character pointer variables.
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
if ((sym->attr.pointer || sym->attr.allocatable)
if ((sym->attr.pointer || sym->attr.allocatable
|| gfc_is_associate_pointer (sym))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result

15
gcc/fortran/trans-types.c
View File

@ -1183,13 +1183,13 @@ gfc_is_nodesc_array (gfc_symbol * sym)
if (sym->attr.pointer || sym->attr.allocatable)
return 0;
/* We want a descriptor for associate-name arrays that do not have an
explicitely known shape already. */
if (sym->assoc && sym->as->type != AS_EXPLICIT)
return 0;
if (sym->attr.dummy)
{
if (sym->as->type != AS_ASSUMED_SHAPE)
return 1;
else
return 0;
}
return sym->as->type != AS_ASSUMED_SHAPE;
if (sym->attr.result || sym->attr.function)
return 0;
@ -1798,7 +1798,8 @@ gfc_sym_type (gfc_symbol * sym)
}
else
{
if (sym->attr.allocatable || sym->attr.pointer)
if (sym->attr.allocatable || sym->attr.pointer
|| gfc_is_associate_pointer (sym))
type = gfc_build_pointer_type (sym, type);
if (sym->attr.pointer || sym->attr.cray_pointee)
GFC_POINTER_TYPE_P (type) = 1;

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
2010-08-17 Daniel Kraft <d@domob.eu>
PR fortran/38936
* gfortran.dg/associate_1.f03: Extended to test newly supported
features like association to variables.
* gfortran.dg/associate_3.f03: Removed check for illegal change
of associate-name here...
* gfortran.dg/associate_5.f03: ...and added it here.
* gfortran.dg/associate_6.f03: No longer XFAIL'ed.
* gfortran.dg/associate_7.f03: New test.
2010-08-15 Kaz Kojima <kkojima@gcc.gnu.org>
* gcc.dg/tree-ssa/pr42585.c: Skip dump scan on sh.

62
gcc/testsuite/gfortran.dg/associate_1.f03
View File

@ -1,5 +1,5 @@
! { dg-do run }
! { dg-options "-std=f2003 -fall-intrinsics" }
! { dg-options "-std=f2003 -fall-intrinsics -cpp" }
! PR fortran/38936
! Check the basic semantics of the ASSOCIATE construct.
@ -8,6 +8,13 @@ PROGRAM main
IMPLICIT NONE
REAL :: a, b, c
INTEGER, ALLOCATABLE :: arr(:)
INTEGER :: mat(3, 3)
TYPE :: myt
INTEGER :: comp
END TYPE myt
TYPE(myt) :: tp
a = -2.0
b = 3.0
@ -20,9 +27,6 @@ PROGRAM main
IF (ABS (t - a - b) > 1.0e-3) CALL abort ()
END ASSOCIATE
! TODO: Test association to variables when that is supported.
! TODO: Test association to derived types.
! Test association to arrays.
ALLOCATE (arr(3))
arr = (/ 1, 2, 3 /)
@ -34,6 +38,12 @@ PROGRAM main
IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
END ASSOCIATE
! Target is vector-indexed.
ASSOCIATE (foo => arr((/ 3, 1 /)))
IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) CALL abort ()
IF (foo(1) /= 3 .OR. foo(2) /= 1) CALL abort ()
END ASSOCIATE
! Named and nested associate.
myname: ASSOCIATE (x => a - b * c)
ASSOCIATE (y => 2.0 * x)
@ -49,6 +59,33 @@ PROGRAM main
END ASSOCIATE
END ASSOCIATE
! Association to variables.
mat = 0
mat(2, 2) = 5;
ASSOCIATE (x => arr(2), y => mat(2:3, 1:2))
IF (x /= 2) CALL abort ()
IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
CALL abort ()
IF (y(1, 2) /= 5) CALL abort ()
x = 7
y = 8
END ASSOCIATE
IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) CALL abort ()
! Association to derived type and component.
tp = myt (1)
ASSOCIATE (x => tp, y => tp%comp)
! FIXME: Parsing of derived-type associate names, tests with x.
IF (y /= 1) CALL abort ()
y = 5
END ASSOCIATE
IF (tp%comp /= 5) CALL abort ()
! Association to character variables.
! FIXME: Enable character test, once this works.
!CALL test_char (5)
CONTAINS
FUNCTION func ()
@ -56,4 +93,21 @@ CONTAINS
func = (/ 1, 3, 5 /)
END FUNCTION func
#if 0
! Test association to character variable with automatic length.
SUBROUTINE test_char (n)
INTEGER, INTENT(IN) :: n
CHARACTER(LEN=n) :: str
str = "foobar"
ASSOCIATE (my => str)
IF (LEN (my) /= n) CALL abort ()
IF (my /= "fooba") CALL abort ()
my = "abcdef"
END ASSOCIATE
IF (str /= "abcde") CALL abort ()
END SUBROUTINE test_char
#endif
END PROGRAM main

4
gcc/testsuite/gfortran.dg/associate_3.f03
View File

@ -30,10 +30,6 @@ PROGRAM main
ASSOCIATE (a => 1, b => 2, a => 3) ! { dg-error "Duplicate name 'a'" }
ASSOCIATE (a => 5)
a = 4 ! { dg-error "variable definition context" }
ENd ASSOCIATE
ASSOCIATE (a => 5)
INTEGER :: b ! { dg-error "Unexpected data declaration statement" }
END ASSOCIATE

13
gcc/testsuite/gfortran.dg/associate_5.f03
View File

@ -6,8 +6,21 @@
PROGRAM main
IMPLICIT NONE
INTEGER :: nontarget
INTEGER :: arr(3)
INTEGER, POINTER :: ptr
ASSOCIATE (a => 5) ! { dg-error "is used as array" }
PRINT *, a(3)
END ASSOCIATE
ASSOCIATE (a => nontarget)
ptr => a ! { dg-error "neither TARGET nor POINTER" }
END ASSOCIATE
ASSOCIATE (a => 5, & ! { dg-error "variable definition context" }
b => arr((/ 1, 3 /))) ! { dg-error "variable definition context" }
a = 4
b = 7
END ASSOCIATE
END PROGRAM main

7
gcc/testsuite/gfortran.dg/associate_6.f03
View File

@ -7,8 +7,6 @@
! Contributed by Daniel Kraft, d@domob.eu.
! FIXME: XFAIL'ed because this is not yet implemented 'correctly'.
MODULE m
IMPLICIT NONE
@ -31,8 +29,11 @@ PROGRAM main
ASSOCIATE (arr => func (4))
! func should only be called once here, not again for the bounds!
IF (LBOUND (arr, 1) /= 1 .OR. UBOUND (arr, 1) /= 4) CALL abort ()
IF (arr(1) /= 1 .OR. arr(4) /= 4) CALL abort ()
END ASSOCIATE
END PROGRAM main
! { dg-final { cleanup-modules "m" } }
! { dg-final { scan-tree-dump-times "func" 2 "original" { xfail *-*-* } } }
! { dg-final { scan-tree-dump-times "func" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

21
gcc/testsuite/gfortran.dg/associate_7.f03 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do run }
! { dg-options "-std=f2003 -fall-intrinsics" }
! PR fortran/38936
! Check association and pointers.
! Contributed by Daniel Kraft, d@domob.eu.
PROGRAM main
IMPLICIT NONE
INTEGER, TARGET :: tgt
INTEGER, POINTER :: ptr
tgt = 1
ASSOCIATE (x => tgt)
ptr => x
IF (ptr /= 1) CALL abort ()
ptr = 2
END ASSOCIATE
IF (tgt /= 2) CALL abort ()
END PROGRAM main