Hi Harald, Please find an updated version of the patch that rolls in Steve's patch for PR114141, fixes unlimited polymorphic function selectors and cures the memory leaks. I apologise for not working on this sooner but, as I informed you, I have been away for an extended trip to Australia.
The chunks that fix PR114141 are picked out in comment 14 to the PR and the cures to the problems that you found in the first review are found at trans-stmt.cc:2047-49. Regtests fine. OK for trunk, bearing in mind that most of the patch is ring fenced by the inferred_type flag? Cheers Paul On Mon, 8 Jan 2024 at 21:53, Harald Anlauf <anl...@gmx.de> wrote: > Hi Paul, > > your patch looks already very impressive! > > Regarding the patch as is, I am still trying to grok it, even with your > explanations at hand... > > While the testcase works as advertised, I noticed that it exhibits a > runtime memleak that occurs for (likely) each case where the associate > target is an allocatable, class-valued function result. > > I tried to produce a minimal testcase using class(*), which apparently > is not handled by your patch (it ICEs for me): > > program p > implicit none > class(*), allocatable :: x(:) > x = foo() > call prt (x) > deallocate (x) > ! up to here no memleak... > associate (var => foo()) > call prt (var) > end associate > contains > function foo() result(res) > class(*), allocatable :: res(:) > res = [42] > end function foo > subroutine prt (x) > class(*), intent(in) :: x(:) > select type (x) > type is (integer) > print *, x > class default > stop 99 > end select > end subroutine prt > end > > Traceback (truncated): > > foo.f90:9:18: > > 9 | call prt (var) > | 1 > internal compiler error: tree check: expected record_type or union_type > or qual_union_type, have function_type in gfc_class_len_get, at > fortran/trans-expr.cc:271 > 0x19fd5d5 tree_check_failed(tree_node const*, char const*, int, char > const*, ...) > ../../gcc-trunk/gcc/tree.cc:8952 > 0xe1562d tree_check3(tree_node*, char const*, int, char const*, > tree_code, tree_code, tree_code) > ../../gcc-trunk/gcc/tree.h:3652 > 0xe3e264 gfc_class_len_get(tree_node*) > ../../gcc-trunk/gcc/fortran/trans-expr.cc:271 > 0xecda48 trans_associate_var > ../../gcc-trunk/gcc/fortran/trans-stmt.cc:2325 > 0xecdd09 gfc_trans_block_construct(gfc_code*) > ../../gcc-trunk/gcc/fortran/trans-stmt.cc:2383 > [...] > > I don't see anything wrong with it: NAG groks it, like Nvidia and Flang, > while Intel crashes at runtime. > > Can you have another brief look? > > Thanks, > Harald > > > On 1/6/24 18:26, Paul Richard Thomas wrote: > > These PRs come about because of gfortran's single pass parsing. If the > > function in the title is parsed after the associate construct, then its > > type and rank are not known. The point at which this becomes a problem is > > when expressions within the associate block are parsed. primary.cc > > (gfc_match_varspec) could already deal with intrinsic types and so > > component references were the trigger for the problem. > > > > The two major parts of this patch are the fixup needed in > gfc_match_varspec > > and the resolution of expressions with references in resolve.cc > > (gfc_fixup_inferred_type_refs). The former relies on the two new > functions > > in symbol.cc to search for derived types with an appropriate component to > > match the component reference and then set the associate name to have a > > matching derived type. gfc_fixup_inferred_type_refs is called in > resolution > > and so the type of the selector function is known. > > gfc_fixup_inferred_type_refs ensures that the component references use > this > > derived type and that array references occur in the right place in > > expressions and match preceding array specs. Most of the work in > preparing > > the patch was sorting out cases where the selector was not a derived type > > but, instead, a class function. If it were not for this, the patch would > > have been submitted six months ago :-( > > > > The patch is relatively safe because most of the chunks are guarded by > > testing for the associate name being an inferred type, which is set in > > gfc_match_varspec. For this reason, I do not think it likely that the > patch > > will cause regressions. However, it is more than possible that variants > not > > appearing in the submitted testcase will throw up new bugs. > > > > Jerry has already given the patch a whirl and found that it applies > > cleanly, regtests OK and works as advertised. > > > > OK for trunk? > > > > Paul > ...snip...
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ce31a93abcd..abe89630be3 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -815,6 +815,56 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
}
+/* Change class, using gfc_build_class_symbol. This is needed for associate
+ names, when rank changes or a derived type is produced by resolution. */
+
+void
+gfc_change_class (gfc_typespec *ts, symbol_attribute *sym_attr,
+ gfc_array_spec *sym_as, int rank, int corank)
+{
+ symbol_attribute attr;
+ gfc_component *c;
+ gfc_array_spec *as = NULL;
+ gfc_symbol *der = ts->u.derived;
+
+ ts->type = BT_CLASS;
+ attr = *sym_attr;
+ attr.class_ok = 0;
+ attr.associate_var = 1;
+ attr.class_pointer = 1;
+ attr.allocatable = 0;
+ attr.pointer = 1;
+ attr.dimension = rank ? 1 : 0;
+ if (rank)
+ {
+ if (sym_as)
+ as = gfc_copy_array_spec (sym_as);
+ else
+ {
+ as = gfc_get_array_spec ();
+ as->rank = rank;
+ as->type = AS_DEFERRED;
+ as->corank = corank;
+ }
+ }
+ if (as && as->corank != 0)
+ attr.codimension = 1;
+
+ if (!gfc_build_class_symbol (ts, &attr, &as))
+ gcc_unreachable ();
+
+ gfc_set_sym_referenced (ts->u.derived);
+
+ /* Make sure the _vptr is set. */
+ c = gfc_find_component (ts->u.derived, "_vptr", true, true, NULL);
+ if (c->ts.u.derived == NULL)
+ c->ts.u.derived = gfc_find_derived_vtab (der);
+ /* _vptr now has the _vtab in it, change it to the _vtype. */
+ if (c->ts.u.derived->attr.vtab)
+ c->ts.u.derived = c->ts.u.derived->ts.u.derived;
+}
+
+
/* Add a procedure pointer component to the vtype
to represent a specific type-bound procedure. */
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 7b154eb3ca7..99b577c91c4 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2692,11 +2692,20 @@ show_code_node (int level, gfc_code *c)
case EXEC_BLOCK:
{
- const char* blocktype;
+ const char *blocktype, *sname = NULL;
gfc_namespace *saved_ns;
gfc_association_list *alist;
- if (c->ext.block.assoc)
+ if (c->ext.block.ns && c->ext.block.ns->code
+ && c->ext.block.ns->code->op == EXEC_SELECT_TYPE)
+ {
+ gfc_expr *fcn = c->ext.block.ns->code->expr1;
+ blocktype = "SELECT TYPE";
+ /* expr1 is _loc(assoc_name->vptr) */
+ if (fcn && fcn->expr_type == EXPR_FUNCTION)
+ sname = fcn->value.function.actual->expr->symtree->n.sym->name;
+ }
+ else if (c->ext.block.assoc)
blocktype = "ASSOCIATE";
else
blocktype = "BLOCK";
@@ -2704,7 +2713,7 @@ show_code_node (int level, gfc_code *c)
fprintf (dumpfile, "%s ", blocktype);
for (alist = c->ext.block.assoc; alist; alist = alist->next)
{
- fprintf (dumpfile, " %s = ", alist->name);
+ fprintf (dumpfile, " %s = ", sname ? sname : alist->name);
show_expr (alist->target);
}
@@ -2735,7 +2744,7 @@ show_code_node (int level, gfc_code *c)
if (c->op == EXEC_SELECT_RANK)
fputs ("SELECT RANK ", dumpfile);
else if (c->op == EXEC_SELECT_TYPE)
- fputs ("SELECT TYPE ", dumpfile);
+ fputs ("SELECT CASE ", dumpfile); // Preceded by SELECT TYPE construct
else
fputs ("SELECT CASE ", dumpfile);
show_expr (c->expr1);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ebba2336e12..70b9faad074 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2963,6 +2963,11 @@ typedef struct gfc_association_list
locus where;
gfc_expr *target;
+
+ /* Used for inferring the derived type of an associate name, whose selector
+ is a sibling derived type function that has not yet been parsed. */
+ gfc_symbol *derived_types;
+ unsigned inferred_type:1;
}
gfc_association_list;
#define gfc_get_association_list() XCNEW (gfc_association_list)
@@ -3529,6 +3534,7 @@ bool gfc_add_component (gfc_symbol *, const char *, gfc_component **);
gfc_symbol *gfc_use_derived (gfc_symbol *);
gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool,
gfc_ref **);
+int gfc_find_derived_types (gfc_symbol *, gfc_namespace *, const char *);
gfc_st_label *gfc_get_st_label (int);
void gfc_free_st_label (gfc_st_label *);
@@ -3795,6 +3801,7 @@ void gfc_free_association_list (gfc_association_list *);
void gfc_expression_rank (gfc_expr *);
bool gfc_op_rank_conformable (gfc_expr *, gfc_expr *);
bool gfc_resolve_ref (gfc_expr *);
+void gfc_fixup_inferred_type_refs (gfc_expr *);
bool gfc_resolve_expr (gfc_expr *);
void gfc_resolve (gfc_namespace *);
void gfc_resolve_code (gfc_code *, gfc_namespace *);
@@ -3988,6 +3995,8 @@ unsigned int gfc_hash_value (gfc_symbol *);
gfc_expr *gfc_get_len_component (gfc_expr *e, int);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **);
+void gfc_change_class (gfc_typespec *, symbol_attribute *,
+ gfc_array_spec *, int, int);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
gfc_symbol *gfc_find_vtab (gfc_typespec *);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
@@ -4018,6 +4027,10 @@ bool gfc_may_be_finalized (gfc_typespec);
#define IS_PROC_POINTER(sym) \
(sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
? CLASS_DATA (sym)->attr.proc_pointer : sym->attr.proc_pointer)
+#define IS_INFERRED_TYPE(expr) \
+ (expr && expr->expr_type == EXPR_VARIABLE \
+ && expr->symtree->n.sym->assoc \
+ && expr->symtree->n.sym->assoc->inferred_type)
/* frontend-passes.cc */
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index eee569dac91..64f61c50c66 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -1963,6 +1963,20 @@ gfc_match_associate (void)
goto assocListError;
}
+ /* If the selector expression is enclosed in parentheses and the
+ expression is not a variable, throw the parentheses away. */
+ while (newAssoc->target->expr_type == EXPR_OP
+ && newAssoc->target->value.op.op == INTRINSIC_PARENTHESES)
+ {
+ if (newAssoc->target->value.op.op1->expr_type == EXPR_VARIABLE)
+ break;
+ else
+ {
+ gfc_expr *e = gfc_copy_expr (newAssoc->target->value.op.op1);
+ gfc_replace_expr (newAssoc->target, e);
+ }
+ }
+
/* 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. This is set during resolution. */
@@ -6322,7 +6336,8 @@ gfc_match_select (void)
/* Transfer the selector typespec to the associate name. */
static void
-copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
+copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
+ bool select_type = false)
{
gfc_ref *ref;
gfc_symbol *assoc_sym;
@@ -6405,12 +6420,30 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
assoc_sym->as = NULL;
build_class_sym:
- if (selector->ts.type == BT_CLASS)
+ /* Deal with the very specific case of a SELECT_TYPE selector being an
+ associate_name whose type has been identified by component references.
+ It must be assumed that it will be identified as a CLASS expression,
+ so convert it now. */
+ if (select_type
+ && IS_INFERRED_TYPE (selector)
+ && selector->ts.type == BT_DERIVED)
+ {
+ gfc_find_derived_vtab (selector->ts.u.derived);
+ /* The correct class container has to be available. */
+ assoc_sym->ts.u.derived = selector->ts.u.derived;
+ assoc_sym->ts.type = BT_CLASS;
+ assoc_sym->attr.pointer = 1;
+ if (!selector->ts.u.derived->attr.is_class)
+ gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
+ associate->ts = assoc_sym->ts;
+ }
+ else if (selector->ts.type == BT_CLASS)
{
/* The correct class container has to be available. */
assoc_sym->ts.type = BT_CLASS;
assoc_sym->ts.u.derived = CLASS_DATA (selector)
- ? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived;
+ ? CLASS_DATA (selector)->ts.u.derived
+ : selector->ts.u.derived;
assoc_sym->attr.pointer = 1;
gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
}
@@ -6438,7 +6471,7 @@ build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2)
if (expr2->ts.type == BT_UNKNOWN)
sym->attr.untyped = 1;
else
- copy_ts_from_selector_to_associate (expr1, expr2);
+ copy_ts_from_selector_to_associate (expr1, expr2, true);
sym->attr.flavor = FL_VARIABLE;
sym->attr.referenced = 1;
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index a4fda6e5eb6..a2bf328f681 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5150,6 +5150,17 @@ parse_associate (void)
sym->declared_at = a->where;
gfc_set_sym_referenced (sym);
+ /* If the selector is a inferred type then the associate_name had better
+ be as well. Use array references, if present, to identify it as an
+ array. */
+ if (IS_INFERRED_TYPE (a->target))
+ {
+ sym->assoc->inferred_type = 1;
+ for (gfc_ref *r = a->target->ref; r; r = r->next)
+ if (r->type == REF_ARRAY)
+ sym->attr.dimension = 1;
+ }
+
/* Initialize the typespec. It is not available in all cases,
however, as it may only be set on the target during resolution.
Still, sometimes it helps to have it right now -- especially
@@ -5176,21 +5187,41 @@ parse_associate (void)
&& sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ /* If the function has been parsed, go straight to the result to
+ obtain the expression rank. */
+ if (target->expr_type == EXPR_FUNCTION
+ && target->symtree
+ && target->symtree->n.sym)
+ {
+ tsym = target->symtree->n.sym;
+ if (!tsym->result)
+ tsym->result = tsym;
+ sym->ts = tsym->result->ts;
+ if (sym->ts.type == BT_CLASS)
+ {
+ if (CLASS_DATA (sym)->as)
+ target->rank = CLASS_DATA (sym)->as->rank;
+ sym->attr.class_ok = 1;
+ }
+ else
+ target->rank = tsym->result->as ? tsym->result->as->rank : 0;
+ }
+
/* Check if the target expression is array valued. This cannot be done
by calling gfc_resolve_expr because the context is unavailable.
However, the references can be resolved and the rank of the target
expression set. */
- if (target->ref && gfc_resolve_ref (target)
+ if (!sym->assoc->inferred_type
+ && target->ref && gfc_resolve_ref (target)
&& target->expr_type != EXPR_ARRAY
&& target->expr_type != EXPR_COMPCALL)
gfc_expression_rank (target);
/* Determine whether or not function expressions with unknown type are
structure constructors. If so, the function result can be converted
- to be a derived type.
- TODO: Deal with references to sibling functions that have not yet been
- parsed (PRs 89645 and 99065). */
- if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
+ to be a derived type. */
+ if (target->expr_type == EXPR_FUNCTION
+ && target->ts.type == BT_UNKNOWN)
{
gfc_symbol *derived;
/* The derived type has a leading uppercase character. */
@@ -5200,16 +5231,7 @@ parse_associate (void)
{
sym->ts.type = BT_DERIVED;
sym->ts.u.derived = derived;
- }
- else if (target->symtree && (tsym = target->symtree->n.sym))
- {
- sym->ts = tsym->result ? tsym->result->ts : tsym->ts;
- if (sym->ts.type == BT_CLASS)
- {
- if (CLASS_DATA (sym)->as)
- target->rank = CLASS_DATA (sym)->as->rank;
- sym->attr.class_ok = 1;
- }
+ sym->assoc->inferred_type = 0;
}
}
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 12e7bf3c873..c64ebf67c70 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2057,6 +2057,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
bool unknown;
bool inquiry;
bool intrinsic;
+ bool inferred_type;
locus old_loc;
char sep;
@@ -2087,6 +2088,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (sym->assoc && sym->assoc->target)
tgt_expr = sym->assoc->target;
+ inferred_type = IS_INFERRED_TYPE (primary);
+
+ /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
+ selector has not been parsed, can generate errors with array and component
+ refs.. Use 'inferred_type' as a flag to suppress these errors. */
+ if (!inferred_type
+ && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
+ && !sym->attr.codimension
+ && sym->attr.select_type_temporary
+ && !sym->attr.select_rank_temporary)
+ inferred_type = true;
+
/* For associate names, we may not yet know whether they are arrays or not.
If the selector expression is unambiguously an array; eg. a full array
or an array section, then the associate name must be an array and we can
@@ -2136,7 +2149,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
sym->ts.u.derived = tgt_expr->ts.u.derived;
}
- if ((equiv_flag && gfc_peek_ascii_char () == '(')
+ if ((inferred_type && !sym->as && gfc_peek_ascii_char () == '(')
+ || (equiv_flag && gfc_peek_ascii_char () == '(')
|| gfc_peek_ascii_char () == '[' || sym->attr.codimension
|| (sym->attr.dimension && sym->ts.type != BT_CLASS
&& !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
@@ -2194,7 +2208,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
inquiry = false;
if (m == MATCH_YES && sep == '%'
&& primary->ts.type != BT_CLASS
- && primary->ts.type != BT_DERIVED)
+ && (primary->ts.type != BT_DERIVED || inferred_type))
{
match mm;
old_loc = gfc_current_locus;
@@ -2209,7 +2223,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
gfc_set_default_type (sym, 0, sym->ns);
/* See if there is a usable typespec in the "no IMPLICIT type" error. */
- if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
+ if ((sym->ts.type == BT_UNKNOWN || inferred_type)
+ && m == MATCH_YES)
{
bool permissible;
@@ -2220,7 +2235,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|| tgt_expr->symtree->n.sym->attr.if_source
== IFSRC_DECL);
permissible = permissible
- || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
+ || (tgt_expr && (tgt_expr->expr_type == EXPR_OP
+ || (inquiry && tgt_expr->expr_type == EXPR_FUNCTION)));
if (permissible)
{
@@ -2228,6 +2244,31 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
sym->ts = tgt_expr->ts;
}
+ /* If this hasn't done the trick and the target expression is a function,
+ then this must be a derived type if 'name' matches an accessible type
+ both in this namespace and the as yet unparsed sibling function. */
+ if (tgt_expr && tgt_expr->expr_type == EXPR_FUNCTION
+ && (sym->ts.type == BT_UNKNOWN || inferred_type)
+ && gfc_find_derived_types (sym, gfc_current_ns, name))
+ {
+ sym->assoc->inferred_type = 1;
+ /* The first returned type is as good as any at this stage. */
+ gfc_symbol **dts = &sym->assoc->derived_types;
+ tgt_expr->ts.type = BT_DERIVED;
+ tgt_expr->ts.kind = 0;
+ tgt_expr->ts.u.derived = *dts;
+ sym->ts = tgt_expr->ts;
+ /* Delete the dt list to prevent interference with trans-type.cc's
+ treatment of derived type decls, even if this process has to be
+ done again for another primary expression. */
+ while (*dts && (*dts)->dt_next)
+ {
+ gfc_symbol **tmp = &(*dts)->dt_next;
+ *dts = NULL;
+ dts = tmp;
+ }
+ }
+
if (sym->ts.type == BT_UNKNOWN)
{
gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
@@ -2294,6 +2335,17 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
break;
}
+ /* With 'associate(x => sin(cmplx(1,0)))', gfortran gets here
+ with an unknown type-spec for primary, but it can be
+ gleaned from the associate target. */
+ if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
+ && primary->ts.type == BT_UNKNOWN
+ && primary->symtree && primary->symtree->n.sym
+ && primary->symtree->n.sym->assoc
+ && primary->symtree->n.sym->assoc->target
+ && primary->symtree->n.sym->assoc->target->ts.type == BT_COMPLEX)
+ primary->ts = primary->symtree->n.sym->assoc->target->ts;
+
if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
&& primary->ts.type != BT_COMPLEX)
{
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 02acc4aef31..3f48ec34932 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5866,6 +5866,13 @@ resolve_variable (gfc_expr *e)
return false;
}
+ /* Guessed type variables are associate_names whose selector had not been
+ parsed at the time that the construct was parsed. Now the namespace is
+ being resolved, the TKR of the selector will be available for fixup of
+ the associate_name. */
+ if (IS_INFERRED_TYPE (e) && e->ref)
+ gfc_fixup_inferred_type_refs (e);
+
/* For variables that are used in an associate (target => object) where
the object's basetype is array valued while the target is scalar,
the ts' type of the component refs is still array valued, which
@@ -6171,6 +6178,115 @@ resolve_procedure:
}
+/* 'sym' was initially guessed to be derived type but has been corrected
+ in resolve_assoc_var to be a class entity or the derived type correcting.
+ If a class entity it will certainly need the _data reference or the
+ reference derived type symbol correcting in the first component ref if
+ a derived type. */
+
+void
+gfc_fixup_inferred_type_refs (gfc_expr *e)
+{
+ gfc_ref *ref;
+ gfc_symbol *sym, *derived;
+ gfc_expr *target;
+ sym = e->symtree->n.sym;
+
+ /* This is an associate_name whose selector is a component ref of a selector
+ that is a inferred type associate_name. */
+ if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+ {
+ e->rank = sym->as ? sym->as->rank : 0;
+ sym->attr.dimension = e->rank ? 1 : 0;
+ if (!e->rank && e->ref->type == REF_ARRAY)
+ {
+ ref = e->ref;
+ e->ref = ref->next;
+ free (ref);
+ }
+ return;
+ }
+
+ derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
+ : sym->ts.u.derived;
+
+ /* Ensure that class symbols have an array spec and ensure that there
+ is a _data field reference following class type references. */
+ if (sym->ts.type == BT_CLASS
+ && sym->assoc->target->ts.type == BT_CLASS)
+ {
+ e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
+ sym->attr.dimension = 0;
+ CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
+ if (e->ref && (e->ref->type != REF_COMPONENT
+ || e->ref->u.c.component->name[0] != '_'))
+ {
+ ref = gfc_get_ref ();
+ ref->type = REF_COMPONENT;
+ ref->next = e->ref;
+ e->ref = ref;
+ ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
+ true, true, NULL);
+ ref->u.c.sym = sym->ts.u.derived;
+ }
+ }
+
+ /* Proceed as far as the first component reference and ensure that the
+ correct derived type is being used. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ {
+ if (ref->u.c.component->name[0] != '_')
+ ref->u.c.sym = derived;
+ else
+ ref->u.c.sym = sym->ts.u.derived;
+ break;
+ }
+
+ /* Verify that the type inferrence mechanism has not introduced a spurious
+ array reference. This can happen with an associate name, whose selector
+ is an element of another inferred type. */
+ target = e->symtree->n.sym->assoc->target;
+ if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
+ && e != target && !target->rank)
+ {
+ /* First case: array ref after the scalar class or derived associate_name. */
+ if (e->ref && e->ref->type == REF_ARRAY
+ && e->ref->u.ar.type != AR_ELEMENT)
+ {
+ ref = e->ref;
+ e->ref = ref->next;
+ free (ref);
+
+ /* If it hasn't a ref to the '_data' field supply one. */
+ if (sym->ts.type == BT_CLASS
+ && !(e->ref->type == REF_COMPONENT
+ && strcmp (e->ref->u.c.component->name, "_data")))
+ {
+ gfc_ref *new_ref;
+ gfc_find_component (e->symtree->n.sym->ts.u.derived,
+ "_data", true, true, &new_ref);
+ new_ref->next = e->ref;
+ e->ref = new_ref;
+ }
+ }
+ /* 2nd case: a ref to the '_data' field followed by an array ref. */
+ else if (e->ref && e->ref->type == REF_COMPONENT
+ && strcmp (e->ref->u.c.component->name, "_data") == 0
+ && e->ref->next && e->ref->next->type == REF_ARRAY
+ && e->ref->next->u.ar.type != AR_ELEMENT)
+ {
+ ref = e->ref->next;
+ e->ref->next = e->ref->next->next;
+ free (ref);
+ }
+ }
+
+ /* Now that all the references are OK, get the expression rank. */
+ gfc_expression_rank (e);
+}
+
+
/* Checks to see that the correct symbol has been host associated.
The only situations where this arises are:
(i) That in which a twice contained function is parsed after
@@ -9263,6 +9379,46 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
return;
}
+ if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
+ {
+ symbol_attribute attr;
+
+ /* By now, the type of the target has been fixed up. */
+ if (sym->ts.type == BT_DERIVED
+ && target->ts.type == BT_CLASS
+ && !UNLIMITED_POLY (target))
+ {
+ sym->ts = CLASS_DATA (target)->ts;
+ if (!sym->as)
+ sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
+ attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+ sym->attr.dimension = target->rank ? 1 : 0;
+ gfc_change_class (&sym->ts, &attr, sym->as,
+ target->rank, gfc_get_corank (target));
+ sym->as = NULL;
+ }
+ else if (target->ts.type == BT_DERIVED
+ && target->symtree->n.sym->ts.type == BT_CLASS
+ && IS_INFERRED_TYPE (target)
+ && target->ref && target->ref->next
+ && target->ref->next->type == REF_ARRAY
+ && !target->ref->next->next)
+ {
+ sym->ts = target->ts;
+ attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+ sym->attr.dimension = target->rank ? 1 : 0;
+ gfc_change_class (&sym->ts, &attr, sym->as,
+ target->rank, gfc_get_corank (target));
+ sym->as = NULL;
+ target->ts = sym->ts;
+ }
+ else if ((target->ts.type == BT_DERIVED)
+ || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
+ && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
+ sym->ts = target->ts;
+ }
+
+
if (target->expr_type == EXPR_NULL)
{
gfc_error ("Selector at %L cannot be NULL()", &target->where);
@@ -9289,15 +9445,50 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
|| gfc_is_ptr_fcn (target));
/* Finally resolve if this is an array or not. */
+ if (target->expr_type == EXPR_FUNCTION
+ && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
+ {
+ gfc_expression_rank (target);
+ if (target->ts.type == BT_DERIVED
+ && !sym->as
+ && target->symtree->n.sym->as)
+ {
+ sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
+ sym->attr.dimension = 1;
+ }
+ else if (target->ts.type == BT_CLASS
+ && CLASS_DATA (target)->as)
+ {
+ target->rank = CLASS_DATA (target)->as->rank;
+ if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
+ {
+ sym->ts = target->ts;
+ sym->attr.dimension = 0;
+ }
+ }
+ }
+
+
if (sym->attr.dimension && target->rank == 0)
{
/* primary.cc makes the assumption that a reference to an associate
name followed by a left parenthesis is an array reference. */
- if (sym->ts.type != BT_CHARACTER)
- gfc_error ("Associate-name %qs at %L is used as array",
- sym->name, &sym->declared_at);
- sym->attr.dimension = 0;
- return;
+ if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
+ {
+ gfc_expression_rank (sym->assoc->target);
+ sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
+ if (!sym->attr.dimension && sym->as)
+ sym->as = NULL;
+ }
+
+ if (sym->attr.dimension && target->rank == 0)
+ {
+ if (sym->ts.type != BT_CHARACTER)
+ gfc_error ("Associate-name %qs at %L is used as array",
+ sym->name, &sym->declared_at);
+ sym->attr.dimension = 0;
+ return;
+ }
}
/* We cannot deal with class selectors that need temporaries. */
@@ -9356,7 +9547,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
correct this now. */
gfc_typespec *ts = &target->ts;
gfc_ref *ref;
- gfc_component *c;
+
for (ref = target->ref; ref != NULL; ref = ref->next)
{
switch (ref->type)
@@ -9374,32 +9565,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
}
/* Create a scalar instance of the current class type. Because the
rank of a class array goes into its name, the type has to be
- rebuild. The alternative of (re-)setting just the attributes
+ rebuilt. The alternative of (re-)setting just the attributes
and as in the current type, destroys the type also in other
places. */
as = NULL;
sym->ts = *ts;
sym->ts.type = BT_CLASS;
attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
- attr.class_ok = 0;
- attr.associate_var = 1;
- attr.dimension = attr.codimension = 0;
- attr.class_pointer = 1;
- if (!gfc_build_class_symbol (&sym->ts, &attr, &as))
- gcc_unreachable ();
- /* Make sure the _vptr is set. */
- c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL);
- if (c->ts.u.derived == NULL)
- c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived);
- CLASS_DATA (sym)->attr.pointer = 1;
- CLASS_DATA (sym)->attr.class_pointer = 1;
- gfc_set_sym_referenced (sym->ts.u.derived);
- gfc_commit_symbol (sym->ts.u.derived);
- /* _vptr now has the _vtab in it, change it to the _vtype. */
- if (c->ts.u.derived->attr.vtab)
- c->ts.u.derived = c->ts.u.derived->ts.u.derived;
- c->ts.u.derived->ns->types_resolved = 0;
- resolve_types (c->ts.u.derived->ns);
+ gfc_change_class (&sym->ts, &attr, as, 0, 0);
+ sym->as = NULL;
}
}
@@ -9443,6 +9617,14 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
}
}
+ if (sym->ts.type == BT_CLASS
+ && IS_INFERRED_TYPE (target)
+ && target->ts.type == BT_DERIVED
+ && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
+ && target->ref && target->ref->next
+ && target->ref->next->type == REF_ARRAY)
+ target->ts = target->symtree->n.sym->ts;
+
/* If the target is a good class object, so is the associate variable. */
if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
sym->attr.class_ok = 1;
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 5d9852c79e0..6d8cdf39f94 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -291,6 +291,19 @@ bool
gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
gfc_typespec *ts;
+ gfc_expr *e;
+
+ /* Check to see if a function selector of unknown type can be resolved. */
+ if (sym->assoc
+ && (e = sym->assoc->target)
+ && e->expr_type == EXPR_FUNCTION)
+ {
+ if (e->ts.type == BT_UNKNOWN)
+ gfc_resolve_expr (e);
+ sym->ts = e->ts;
+ if (sym->ts.type != BT_UNKNOWN)
+ return true;
+ }
if (sym->ts.type != BT_UNKNOWN)
gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
@@ -307,7 +320,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
"; did you mean %qs?",
sym->name, &sym->declared_at, guessed);
else
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type(symbol)",
sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}
@@ -2402,6 +2415,66 @@ bad:
}
+/* Find all derived types in the uppermost namespace that have a component
+ a component called name and stash them in the assoc field of an
+ associate name variable.
+ This is used to infer the derived type of an associate name, whose selector
+ is a sibling derived type function that has not yet been parsed. Either
+ the derived type is use associated in both contained and sibling procedures
+ or it appears in the uppermost namespace. */
+
+static int cts = 0;
+static void
+find_derived_types (gfc_symbol *sym, gfc_symtree *st, const char *name,
+ bool contained)
+{
+ if (st->n.sym && st->n.sym->attr.flavor == FL_DERIVED
+ && !st->n.sym->attr.is_class
+ && ((contained && st->n.sym->attr.use_assoc) || !contained)
+ && gfc_find_component (st->n.sym, name, true, true, NULL))
+ {
+ /* Do the stashing. */
+ cts++;
+ if (sym->assoc->derived_types)
+ st->n.sym->dt_next = sym->assoc->derived_types;
+ sym->assoc->derived_types = st->n.sym;
+ }
+
+ if (st->left)
+ find_derived_types (sym, st->left, name, contained);
+
+ if (st->right)
+ find_derived_types (sym, st->right, name, contained);
+}
+
+int
+gfc_find_derived_types (gfc_symbol *sym, gfc_namespace *ns, const char *name)
+{
+ gfc_namespace *encompassing = NULL;
+ gcc_assert (sym->assoc);
+
+ cts = 0;
+ while (ns->parent)
+ {
+ if (!ns->parent->parent && ns->proc_name
+ && (ns->proc_name->attr.function || ns->proc_name->attr.subroutine))
+ encompassing = ns;
+ ns = ns->parent;
+ }
+
+ if (!ns->contained)
+ return cts;
+
+ /* Search the top level namespace first. */
+ find_derived_types (sym, ns->sym_root, name, false);
+
+ /* Then the encompassing namespace. */
+ if (encompassing)
+ find_derived_types (sym, encompassing->sym_root, name, true);
+
+ return cts;
+}
+
/* Find the component with the given name in the union type symbol.
If ref is not NULL it will be set to the chain of components through which
the component can actually be accessed. This is necessary for unions because
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d63c304661a..bd14ce99ed6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -3142,6 +3142,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
gcc_assert (se->string_length);
}
+ /* Some expressions leak through that haven't been fixed up. */
+ if (IS_INFERRED_TYPE (expr) && expr->ref)
+ gfc_fixup_inferred_type_refs (expr);
+
gfc_typespec *ts = &sym->ts;
while (ref)
{
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index e09828e218b..1ec76f9778c 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1747,9 +1747,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
e = sym->assoc->target;
class_target = (e->expr_type == EXPR_VARIABLE)
- && e->ts.type == BT_CLASS
- && (gfc_is_class_scalar_expr (e)
- || gfc_is_class_array_ref (e, NULL));
+ && e->ts.type == BT_CLASS
+ && (gfc_is_class_scalar_expr (e)
+ || gfc_is_class_array_ref (e, NULL));
unlimited = UNLIMITED_POLY (e);
@@ -2043,6 +2043,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
gfc_conv_expr (&se, e);
se.expr = gfc_evaluate_now (se.expr, &se.pre);
+ /* Finalize the expression and free if it is allocatable. */
+ gfc_finalize_tree_expr (&se, NULL, gfc_expr_attr (e), e->rank);
+ gfc_add_block_to_block (&se.post, &se.finalblock);
+ need_len_assign = false;
}
else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
{
@@ -2157,26 +2161,36 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
tree stmp;
tree dtmp;
+ tree ctmp;
- se.expr = ctree;
+ ctmp = ctree;
dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
ctree = gfc_create_var (dtmp, "class");
- stmp = gfc_class_data_get (se.expr);
+ if (IS_INFERRED_TYPE (e)
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+ stmp = se.expr;
+ else
+ stmp = gfc_class_data_get (ctmp);
+
/* Coarray scalar component expressions can emerge from
the front end as array elements of the _data field. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)))
stmp = gfc_conv_descriptor_data_get (stmp);
+
+ if (!POINTER_TYPE_P (TREE_TYPE (stmp)))
+ stmp = gfc_build_addr_expr (NULL, stmp);
+
dtmp = gfc_class_data_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
- stmp = gfc_class_vptr_get (se.expr);
+ stmp = gfc_class_vptr_get (ctmp);
dtmp = gfc_class_vptr_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
if (UNLIMITED_POLY (sym))
{
- stmp = gfc_class_len_get (se.expr);
+ stmp = gfc_class_len_get (ctmp);
dtmp = gfc_class_len_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Tests unlimited polymorphic function selectors in ASSOCIATE.
!
! Contributed by Harald Anlauf <anl...@gmx.de> in
! https://gcc.gnu.org/pipermail/fortran/2024-January/060098.html
!
program p
implicit none
! scalar array
associate (var1 => foo1(), var2 => foo2())
call prt (var1); call prt (var2)
end associate
contains
! Scalar value
function foo1() result(res)
class(*), allocatable :: res
res = 42.0
end function foo1
! Array value
function foo2() result(res)
class(*), allocatable :: res(:)
res = [42, 84]
end function foo2
! Test the associate-name value
subroutine prt (x)
class(*), intent(in) :: x(..)
logical :: ok = .false.
select rank(x)
rank (0)
select type (x)
type is (real)
if (int(x*10) .eq. 420) ok = .true.
end select
rank (1)
select type (x)
type is (integer)
if (all (x .eq. [42, 84])) ok = .true.
end select
end select
if (.not.ok) stop 1
end subroutine prt
end
! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }
! { dg-do run }
! Test fix for PR114141
! Contributed by Steve Kargl <s...@troutmask.apl.washington.edu>
program foo
implicit none
real :: y
complex :: z = cmplx(-1,0)
associate (x => log(cmplx(-1,0)))
y = x%im ! Gave 'Symbol ‘x’ at (1) has no IMPLICIT type'
if (int(100*y)-314 /= 0) stop 1
end associate
! Check wrinkle in comment 1 (parentheses around selector) of the PR is fixed.
associate (x => ((log(cmplx(-1,0)))))
y = x%im ! Gave 'The RE or IM part_ref at (1) must be applied to a
! COMPLEX expression'
if (int(100*y)-314 /= 0) stop 2
end associate
! Make sure that IMAG intrinsic is OK.
associate (x => ((log(cmplx(-1,0)))))
y = imag (x)
if (int(100*y)-314 /= 0) stop 3
end associate
end program
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Tests the fix for PR89645 and 99065, in which derived type or class functions,
! used as associate selectors and which were parsed after the containing scope
! of the associate statement, caused "no IMPLICIT type" and "Syntax" errors.
!
! Contributed by Ian Harvey <ian_har...@bigpond.com>
!
module m
implicit none
type t
integer :: i = 0
end type t
integer :: i = 0
type(t), parameter :: test_array (2) = [t(42),t(84)], &
test_scalar = t(99)
end module m
! DERIVED TYPE VERSION OF THE PROBLEM, AS REPORTED IN THE PRs
module type_selectors
use m
implicit none
private
public foo1
contains
! Since these functions are parsed first, the symbols are available for
! parsing in 'foo'.
function bar1() result(res) ! The array version caused syntax errors in foo
type(t), allocatable :: res(:)
allocate (res, source = test_array)
end
function bar2() result(res) ! Scalar class functions were OK - test anyway
type(t), allocatable :: res
allocate (res, source = test_scalar)
end
subroutine foo1()
! First the array selector
associate (var1 => bar1())
if (any (var1%i .ne. test_array%i)) stop 1
if (var1(2)%i .ne. test_array(2)%i) stop 2
end associate
! Now the scalar selector
associate (var2 => bar2())
if (var2%i .ne. test_scalar%i) stop 3
end associate
! Now the array selector that needed fixing up because the function follows....
associate (var1 => bar3())
if (any (var1%i .ne. test_array%i)) stop 4
if (var1(2)%i .ne. test_array(2)%i) stop 5
end associate
! ....and equivalent scalar selector
associate (var2 => bar4())
if (var2%i .ne. test_scalar%i) stop 6
end associate
end subroutine foo1
! These functions are parsed after 'foo' so the symbols were not available
! for the selectors and the fixup, tested here, was necessary.
function bar3() result(res)
class(t), allocatable :: res(:)
allocate (res, source = test_array)
end
function bar4() result(res)
class(t), allocatable :: res
allocate (res, source = t(99))
end
end module type_selectors
! CLASS VERSION OF THE PROBLEM, WHICH REQUIRED MOST OF THE WORK!
module class_selectors
use m
implicit none
private
public foo2
contains
! Since these functions are parsed first, the symbols are available for
! parsing in 'foo'.
function bar1() result(res) ! The array version caused syntax errors in foo
class(t), allocatable :: res(:)
allocate (res, source = test_array)
end
function bar2() result(res) ! Scalar class functions were OK - test anyway
class(t), allocatable :: res
allocate (res, source = t(99))
end
subroutine foo2()
! First the array selector
associate (var1 => bar1())
if (any (var1%i .ne. test_array%i)) stop 7
if (var1(2)%i .ne. test_array(2)%i) stop 8
select type (x => var1)
type is (t)
if (any (x%i .ne. test_array%i)) stop 9
if (x(1)%i .ne. test_array(1)%i) stop 10
class default
stop 11
end select
end associate
! Now scalar selector
associate (var2 => bar2())
select type (z => var2)
type is (t)
if (z%i .ne. test_scalar%i) stop 12
class default
stop 13
end select
end associate
! This is the array selector that needed the fixup.
associate (var1 => bar3())
if (any (var1%i .ne. test_array%i)) stop 14
if (var1(2)%i .ne. test_array(2)%i) stop 15
select type (x => var1)
type is (t)
if (any (x%i .ne. test_array%i)) stop 16
if (x(1)%i .ne. test_array(1)%i) stop 17
class default
stop 18
end select
end associate
! Now the equivalent scalar selector
associate (var2 => bar4())
select type (z => var2)
type is (t)
if (z%i .ne. test_scalar%i) stop 19
class default
stop 20
end select
end associate
end subroutine foo2
! These functions are parsed after 'foo' so the symbols were not available
! for the selectors and the fixup, tested here, was necessary.
function bar3() result(res)
class(t), allocatable :: res(:)
allocate (res, source = test_array)
end
function bar4() result(res)
class(t), allocatable :: res
allocate (res, source = t(99))
end
end module class_selectors
! THESE TESTS CAUSED PROBLEMS DURING DEVELOPMENT FOR BOTH PARSING ORDERS.
module problem_selectors
implicit none
private
public foo3, foo4
type t
integer :: i
end type t
type s
integer :: i
type(t) :: dt
end type s
type(t), parameter :: test_array (2) = [t(42),t(84)], &
test_scalar = t(99)
type(s), parameter :: test_sarray (2) = [s(142,t(42)),s(184,t(84))]
contains
subroutine foo3()
integer :: i
block
associate (var1 => bar7())
if (any (var1%i .ne. test_array%i)) stop 21
if (var1(2)%i .ne. test_array(2)%i) stop 22
associate (z => var1(1)%i)
if (z .ne. 42) stop 23
end associate
end associate
end block
associate (var2 => bar8())
i = var2(2)%i
associate (var3 => var2%dt)
if (any (var3%i .ne. test_sarray%dt%i)) stop 24
end associate
associate (var4 => var2(2))
if (var4%i .ne. 184) stop 25
end associate
end associate
end subroutine foo3
function bar7() result(res)
type(t), allocatable :: res(:)
allocate (res, source = test_array)
end
function bar8() result(res)
type(s), allocatable :: res(:)
allocate (res, source = test_sarray)
end
subroutine foo4()
integer :: i
block
associate (var1 => bar7())
if (any (var1%i .ne. test_array%i)) stop 26
if (var1(2)%i .ne. test_array(2)%i) stop 27
associate (z => var1(1)%i)
if (z .ne. 42) stop 28
end associate
end associate
end block
associate (var2 => bar8())
i = var2(2)%i
associate (var3 => var2%dt)
if (any (var3%i .ne. test_sarray%dt%i)) stop 29
end associate
associate (var4 => var2(2))
if (var4%i .ne. 184) stop 30
end associate
end associate
end subroutine foo4
end module problem_selectors
module more_problem_selectors
implicit none
private
public foo5, foo6
type t
integer :: i = 0
end type t
type s
integer :: i = 0
type(t) :: dt
end type s
contains
! In this version, the order of declarations of 't' and 's' is such that
! parsing var%i sets the type of var to 't' and this is corrected to 's'
! on parsing var%dt%i
subroutine foo5()
associate (var3 => bar3())
if (var3%i .ne. 42) stop 31
if (var3%dt%i .ne. 84) stop 32
end associate
! Repeat with class version
associate (var4 => bar4())
if (var4%i .ne. 84) stop 33
if (var4%dt%i .ne. 168) stop 34
select type (x => var4)
type is (s)
if (x%i .ne. var4%i) stop 35
if (x%dt%i .ne. var4%dt%i) stop 36
class default
stop 37
end select
end associate
! Ditto with no type component clues for select type
associate (var5 => bar4())
select type (z => var5)
type is (s)
if (z%i .ne. 84) stop 38
if (z%dt%i .ne. 168) stop 39
class default
stop 40
end select
end associate
end subroutine foo5
! Now the array versions
subroutine foo6()
class(s), allocatable :: elem
associate (var6 => bar5())
if (var6(1)%i .ne. 42) stop 41
if (any (var6%dt%i .ne. [84])) stop 42
end associate
! Class version with an assignment to a named variable
associate (var7 => bar6())
elem = var7(2)
if (any (var7%i .ne. [84, 168])) stop 43
if (any (var7%dt%i .ne. [168, 336])) stop 44
end associate
if (elem%i .ne. 168) stop 45
if (elem%dt%i .ne. 336) stop 46
select type (z => elem)
type is (s)
if (z%i .ne. 168) stop 47
if (z%dt%i .ne. 336) stop 48
class default
stop 49
end select
! Array version without type clues before select type
associate (var8 => bar6())
select type (z => var8)
type is (s)
if (any (z%i .ne. [84,168])) stop 50
if (any (z%dt%i .ne. [168,336])) stop 51
class default
stop 52
end select
end associate
end subroutine foo6
type(s) function bar3()
bar3= s(42, t(84))
end
function bar4() result(res)
class(s), allocatable :: res
res = s(84, t(168))
end
function bar5() result (res)
type(s), allocatable :: res(:)
res = [s(42, t(84))]
end
function bar6() result (res)
class(s), allocatable :: res(:)
res = [s(84, t(168)),s(168, t(336))]
end
end module more_problem_selectors
program test
use type_selectors
use class_selectors
use problem_selectors
use more_problem_selectors
call foo1()
call foo2()
call foo3()
call foo4()
call foo5()
call foo6()
end program test
! { dg-final { scan-tree-dump-times "__builtin_free" 18 "original" } }
Change99065.Logs
Description: Binary data
