public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-9489] Fortran: Fix class/derived/complex function associate selectors [PR87477]
@ 2024-03-15 6:53 Paul Thomas
0 siblings, 0 replies; only message in thread
From: Paul Thomas @ 2024-03-15 6:53 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:3fd46d859cda1074125449a4cc680ce59fcebc38
commit r14-9489-g3fd46d859cda1074125449a4cc680ce59fcebc38
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Fri Mar 15 06:52:59 2024 +0000
Fortran: Fix class/derived/complex function associate selectors [PR87477]
2024-03-15 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/87477
PR fortran/89645
PR fortran/99065
PR fortran/114141
PR fortran/114280
* class.cc (gfc_change_class): New function needed for
associate names, when rank changes or a derived type is
produced by resolution
* dump-parse-tree.cc (show_code_node): Make output for SELECT
TYPE more comprehensible.
* expr.cc (find_inquiry_ref): Do not simplify expressions of
an inferred type.
* gfortran.h : Add 'gfc_association_list' to structure
'gfc_association_list'. Add prototypes for
'gfc_find_derived_types', 'gfc_fixup_inferred_type_refs' and
'gfc_change_class'. Add macro IS_INFERRED_TYPE.
* match.cc (copy_ts_from_selector_to_associate): Add bolean arg
'select_type' with default false. If this is a select type name
and the selector is a inferred type, build the class type and
apply it to the associate name.
(build_associate_name): Pass true to 'select_type' in call to
previous.
* parse.cc (parse_associate): If the selector is inferred type
the associate name is too. Make sure that function selector
class and rank, if known, are passed to the associate name. If
a function result exists, pass its typespec to the associate
name.
* primary.cc (resolvable_fcns): New function to check that all
the function references are resolvable.
(gfc_match_varspec): If a scalar derived type select type
temporary has an array reference, match the array reference,
treating this in the same way as an equivalence member. Do not
set 'inquiry' if applied to an unknown type the inquiry name
is ambiguous with the component of an accessible derived type.
Check that resolution of the target expression is OK by testing
if the symbol is declared or is an operator expression, then
using 'resolvable_fcns' recursively. If all is well, resolve
the expression. If this is an inferred type with a component
reference, call 'gfc_find_derived_types' to find a suitable
derived type. If there is an inquiry ref and the symbol either
is of unknown type or is inferred to be a derived type, set the
primary and symbol TKR appropriately.
* resolve.cc (resolve_variable): Call new function below.
(gfc_fixup_inferred_type_refs): New function to ensure that the
expression references for a inferred type are consistent with
the now fixed up selector.
(resolve_assoc_var): Ensure that derived type or class function
selectors transmit the correct arrayspec to the associate name.
(resolve_select_type): If the selector is an associate name of
inferred type and has no component references, the associate
name should have its typespec. Simplify the conversion of a
class array to class scalar by calling 'gfc_change_class'.
Make sure that a class, inferred type selector with an array
ref transfers the typespec from the symbol to the expression.
* symbol.cc (gfc_set_default_type): If an associate name with
unknown type has a selector expression, try resolving the expr.
(find_derived_types, gfc_find_derived_types): New functions
that search for a derived type with a given name.
* trans-expr.cc (gfc_conv_variable): Some inferred type exprs
escape resolution so call 'gfc_fixup_inferred_type_refs'.
* trans-stmt.cc (trans_associate_var): Tidy up expression for
'class_target'. Finalize and free class function results.
Correctly handle selectors that are class functions and class
array references, passed as derived types.
gcc/testsuite/
PR fortran/87477
PR fortran/89645
PR fortran/99065
* gfortran.dg/associate_64.f90 : New test
* gfortran.dg/associate_66.f90 : New test
* gfortran.dg/associate_67.f90 : New test
PR fortran/114141
* gfortran.dg/associate_65.f90 : New test
PR fortran/114280
* gfortran.dg/associate_68.f90 : New test
Diff:
---
gcc/fortran/class.cc | 50 +++++
gcc/fortran/dump-parse-tree.cc | 17 +-
gcc/fortran/expr.cc | 5 +
gcc/fortran/gfortran.h | 15 ++
gcc/fortran/match.cc | 27 ++-
gcc/fortran/parse.cc | 52 +++--
gcc/fortran/primary.cc | 170 ++++++++++++--
gcc/fortran/resolve.cc | 290 +++++++++++++++++++++---
gcc/fortran/symbol.cc | 76 ++++++-
gcc/fortran/trans-expr.cc | 4 +
gcc/fortran/trans-stmt.cc | 28 ++-
gcc/testsuite/gfortran.dg/associate_64.f90 | 345 +++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/associate_65.f90 | 30 +++
gcc/testsuite/gfortran.dg/associate_66.f90 | 45 ++++
gcc/testsuite/gfortran.dg/associate_67.f90 | 41 ++++
gcc/testsuite/gfortran.dg/associate_68.f90 | 79 +++++++
16 files changed, 1197 insertions(+), 77 deletions(-)
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 7bc78663768..87a65036a3d 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2701,11 +2701,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";
@@ -2713,7 +2722,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);
}
@@ -2744,7 +2753,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/expr.cc b/gcc/fortran/expr.cc
index 82a642b01f7..e4b1e8307e3 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1844,6 +1844,11 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
gfc_resolve_expr (tmp);
+ /* Leave these to the backend since the type and kind is not confirmed until
+ resolution. */
+ if (IS_INFERRED_TYPE (tmp))
+ goto cleanup;
+
/* In principle there can be more than one inquiry reference. */
for (; inquiry; inquiry = inquiry->next)
{
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 32b792f85fb..c7039730fad 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2967,6 +2967,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)
@@ -3533,6 +3538,8 @@ 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 *,
+ bool stash = false);
gfc_st_label *gfc_get_st_label (int);
void gfc_free_st_label (gfc_st_label *);
@@ -3799,6 +3806,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 *);
@@ -3925,6 +3933,7 @@ const char *gfc_dt_upper_string (const char *);
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
+bool is_inquiry_ref (const char *, gfc_ref **);
match gfc_match_rvalue (gfc_expr **);
match gfc_match_varspec (gfc_expr*, int, bool, bool);
bool gfc_check_digit (char, int);
@@ -3992,6 +4001,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*,
@@ -4022,6 +4033,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..4539c9bb134 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6322,7 +6322,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 +6406,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 +6457,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..0ab69bb9dce 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2003,7 +2003,7 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
/* Used by gfc_match_varspec() to match an inquiry reference. */
-static bool
+bool
is_inquiry_ref (const char *name, gfc_ref **ref)
{
inquiry_type type;
@@ -2035,6 +2035,29 @@ is_inquiry_ref (const char *name, gfc_ref **ref)
}
+/* Check to see if functions in operator expressions can be resolved now. */
+
+static bool
+resolvable_fcns (gfc_expr *e,
+ gfc_symbol *sym ATTRIBUTE_UNUSED,
+ int *f ATTRIBUTE_UNUSED)
+{
+ bool p;
+ gfc_symbol *s;
+
+ if (e->expr_type != EXPR_FUNCTION)
+ return false;
+
+ s = e && e->symtree && e->symtree->n.sym ? e->symtree->n.sym : NULL;
+ p = s && (s->attr.use_assoc
+ || s->attr.host_assoc
+ || s->attr.if_source == IFSRC_DECL
+ || s->attr.proc == PROC_INTRINSIC
+ || gfc_is_intrinsic (s, 0, e->where));
+ return !p;
+}
+
+
/* Match any additional specifications associated with the current
variable like member references or substrings. If equiv_flag is
set we only match stuff that is allowed inside an EQUIVALENCE
@@ -2057,6 +2080,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 +2111,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 +2172,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,41 +2231,100 @@ 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;
mm = gfc_match_name (name);
- if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
+ /* This is a usable inquiry reference, if the symbol is already known
+ to have a type or no derived types with a component of this name
+ can be found. If this was an inquiry reference with the same name
+ as a derived component and the associate-name type is not derived
+ or class, this is fixed up in 'gfc_fixup_inferred_type_refs'. */
+ if (mm == MATCH_YES && is_inquiry_ref (name, &tmp)
+ && !(sym->ts.type == BT_UNKNOWN
+ && gfc_find_derived_types (sym, gfc_current_ns, name)))
inquiry = true;
gfc_current_locus = old_loc;
}
+ /* Use the default type if there is one. */
if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
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)
+ /* See if the type can be determined by resolution of the selector expression,
+ if allowable now, or inferred from references. */
+ if ((sym->ts.type == BT_UNKNOWN || inferred_type)
+ && m == MATCH_YES)
{
- bool permissible;
-
- /* These target expressions can be resolved at any time. */
- permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
- && (tgt_expr->symtree->n.sym->attr.use_assoc
- || tgt_expr->symtree->n.sym->attr.host_assoc
- || tgt_expr->symtree->n.sym->attr.if_source
- == IFSRC_DECL);
- permissible = permissible
- || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
-
- if (permissible)
+ bool sym_present, resolved = false;
+ gfc_symbol *tgt_sym;
+
+ sym_present = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym;
+ tgt_sym = sym_present ? tgt_expr->symtree->n.sym : NULL;
+
+ /* These target expressions can be resolved at any time:
+ (i) With a declared symbol or intrinsic function; or
+ (ii) An operator expression,
+ just as long as (iii) all the functions in the expression have been
+ declared or are intrinsic. */
+ if (((sym_present // (i)
+ && (tgt_sym->attr.use_assoc
+ || tgt_sym->attr.host_assoc
+ || tgt_sym->attr.if_source == IFSRC_DECL
+ || tgt_sym->attr.proc == PROC_INTRINSIC
+ || gfc_is_intrinsic (tgt_sym, 0, tgt_expr->where)))
+ || (tgt_expr && tgt_expr->expr_type == EXPR_OP)) // (ii)
+ && !gfc_traverse_expr (tgt_expr, NULL, resolvable_fcns, 0) // (iii)
+ && gfc_resolve_expr (tgt_expr))
{
- gfc_resolve_expr (tgt_expr);
sym->ts = tgt_expr->ts;
+ primary->ts = sym->ts;
+ resolved = true;
}
- if (sym->ts.type == BT_UNKNOWN)
+ /* If this hasn't done the trick and the target expression is a function,
+ or an unresolved operator expression, then this must be a derived type
+ if 'name' matches an accessible type both in this namespace and in the
+ as yet unparsed contained function. In principle, the type could have
+ already been inferred to be complex and yet a derived type with a
+ component name 're' or 'im' could be found. */
+ if (tgt_expr
+ && (tgt_expr->expr_type == EXPR_FUNCTION
+ || (!resolved && tgt_expr->expr_type == EXPR_OP))
+ && (sym->ts.type == BT_UNKNOWN
+ || (inferred_type && sym->ts.type != BT_COMPLEX))
+ && gfc_find_derived_types (sym, gfc_current_ns, name, true))
+ {
+ sym->assoc->inferred_type = 1;
+ /* The first returned type is as good as any at this stage. The final
+ determination is made in 'gfc_fixup_inferred_type_refs'*/
+ 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;
+ primary->ts = sym->ts;
+ /* Delete the dt list 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 there is a usable inquiry reference not there are no matching
+ derived types, force the inquiry reference by setting unknown the
+ type of the primary expression. */
+ else if (inquiry && (sym->ts.type == BT_DERIVED && inferred_type)
+ && !gfc_find_derived_types (sym, gfc_current_ns, name))
+ primary->ts.type = BT_UNKNOWN;
+
+ /* An inquiry reference might determine the type, otherwise we have an
+ error. */
+ if (sym->ts.type == BT_UNKNOWN && !inquiry)
{
gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
return MATCH_ERROR;
@@ -2273,6 +2369,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
{
if (tmp)
{
+ gfc_symbol *s;
switch (tmp->u.i)
{
case INQUIRY_RE:
@@ -2294,6 +2391,39 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
break;
}
+ /* If necessary, infer the type of the primary expression
+ and the associate-name using the the inquiry ref.. */
+ s = primary->symtree ? primary->symtree->n.sym : NULL;
+ if (s && s->assoc && s->assoc->target
+ && (s->ts.type == BT_UNKNOWN
+ || (primary->ts.type == BT_UNKNOWN
+ && s->assoc->inferred_type
+ && s->ts.type == BT_DERIVED)))
+ {
+ if (tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
+ {
+ s->ts.type = BT_COMPLEX;
+ s->ts.kind = gfc_default_real_kind;;
+ s->assoc->inferred_type = 1;
+ primary->ts = s->ts;
+ }
+ else if (tmp->u.i == INQUIRY_LEN)
+ {
+ s->ts.type = BT_CHARACTER;
+ s->ts.kind = gfc_default_character_kind;;
+ s->assoc->inferred_type = 1;
+ primary->ts = s->ts;
+ }
+ else if (s->ts.type == BT_UNKNOWN)
+ {
+ /* KIND inquiry gives no clue as to symbol type. */
+ primary->ref = tmp;
+ primary->ts.type = BT_INTEGER;
+ primary->ts.kind = gfc_default_integer_kind;
+ return MATCH_YES;
+ }
+ }
+
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..c5ae826bd6e 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5866,6 +5866,18 @@ 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);
+ /* KIND inquiry ref returns the kind of the target. */
+ if (e->expr_type == EXPR_CONSTANT)
+ return true;
+ }
+
/* 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 +6183,159 @@ 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, *new_ref;
+ gfc_symbol *sym, *derived;
+ gfc_expr *target;
+ sym = e->symtree->n.sym;
+
+ /* An associate_name whose selector is (i) a component ref of a selector
+ that is a inferred type associate_name; or (ii) an intrinsic type that
+ has been inferred from an inquiry ref. */
+ if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+ {
+ sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
+ if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
+ {
+ ref = e->ref;
+ /* A substring misidentified as an array section. */
+ if (sym->ts.type == BT_CHARACTER
+ && ref->u.ar.start[0] && ref->u.ar.end[0]
+ && !ref->u.ar.stride[0])
+ {
+ new_ref = gfc_get_ref ();
+ new_ref->type = REF_SUBSTRING;
+ new_ref->u.ss.start = ref->u.ar.start[0];
+ new_ref->u.ss.end = ref->u.ar.end[0];
+ new_ref->u.ss.length = sym->ts.u.cl;
+ *ref = *new_ref;
+ free (new_ref);
+ }
+ else
+ {
+ e->ref = ref->next;
+ free (ref);
+ }
+ }
+
+ /* It is possible for an inquiry reference to be mistaken for a
+ component reference. Correct this now. */
+ ref = e->ref;
+ if (ref && ref->type == REF_ARRAY)
+ ref = ref->next;
+ if (ref && ref->type == REF_COMPONENT
+ && is_inquiry_ref (ref->u.c.component->name, &new_ref))
+ {
+ e->symtree->n.sym = sym;
+ *ref = *new_ref;
+ gfc_free_ref_list (new_ref);
+ }
+
+ /* The kind of the associate name is best evaluated directly from the
+ selector because of the guesses made in primary.cc, when the type
+ is still unknown. */
+ if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
+ {
+ gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
+ sym->assoc->target->ts.kind);
+ gfc_replace_expr (e, ne);
+ }
+
+ /* Now that the references are all sorted out, set the expression rank
+ and return. */
+ gfc_expression_rank (e);
+ 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 +9428,53 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
return;
}
+ if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
+ {
+ /* By now, the type of the target has been fixed up. */
+ symbol_attribute attr;
+
+ if (sym->ts.type == BT_DERIVED
+ && target->ts.type == BT_CLASS
+ && !UNLIMITED_POLY (target))
+ {
+ /* Inferred to be derived type but the target has type class. */
+ 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 && target->symtree->n.sym
+ && 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)
+ {
+ /* A inferred type selector whose symbol has been determined to be
+ a class array but which only has an array reference. Change the
+ associate name and the selector to class type. */
+ 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))
+ /* Confirmed to be either a derived type or misidentified to be a
+ scalar class object, when the selector is a class array. */
+ sym->ts = target->ts;
+ }
+
+
if (target->expr_type == EXPR_NULL)
{
gfc_error ("Selector at %L cannot be NULL()", &target->where);
@@ -9289,15 +9501,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 +9603,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 +9621,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 +9673,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->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..16adb2a7efb 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,67 @@ 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, bool stash)
+{
+ 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, if required. */
+ cts++;
+ if (stash)
+ {
+ 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, stash);
+
+ if (st->right)
+ find_derived_types (sym, st->right, name, contained, stash);
+}
+
+int
+gfc_find_derived_types (gfc_symbol *sym, gfc_namespace *ns,
+ const char *name, bool stash)
+{
+ 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;
+ }
+
+ /* Search the top level namespace first. */
+ find_derived_types (sym, ns->sym_root, name, false, stash);
+
+ /* Then the encompassing namespace. */
+ if (encompassing && encompassing != ns)
+ find_derived_types (sym, encompassing->sym_root, name, true, stash);
+
+ 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);
diff --git a/gcc/testsuite/gfortran.dg/associate_64.f90 b/gcc/testsuite/gfortran.dg/associate_64.f90
new file mode 100644
index 00000000000..d7fde185bd0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_64.f90
@@ -0,0 +1,345 @@
+! { 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_harvey@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" } }
diff --git a/gcc/testsuite/gfortran.dg/associate_65.f90 b/gcc/testsuite/gfortran.dg/associate_65.f90
new file mode 100644
index 00000000000..04a1437958a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_65.f90
@@ -0,0 +1,30 @@
+! { dg-do run }
+! Test fix for PR114141
+! Contributed by Steve Kargl <sgk@troutmask.apl.washington.edu>
+program foo
+ implicit none
+ real :: y = 0.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,1)))))
+ y = x%im ! Gave 'The RE or IM part_ref at (1) must be applied to a
+ ! COMPLEX expression'
+ if (int(100*y)-235 /= 0) stop 2
+ end associate
+
+! Check that more complex(pun intended!) expressions are OK.
+ associate (x => exp (log(cmplx(-1,0))+cmplx(0,0.5)))
+ y = x%re ! Gave 'Symbol ‘x’ at (1) has no IMPLICIT type'
+ if (int(1000*y)+877 /= 0) stop 3
+ end associate
+
+! Make sure that AIMAG intrinsic is OK.
+ associate (x => ((log(cmplx(-1,0.5)))))
+ y = aimag (x)
+ if (int(100*y)-267 /= 0) stop 4
+ end associate
+end program
diff --git a/gcc/testsuite/gfortran.dg/associate_66.f90 b/gcc/testsuite/gfortran.dg/associate_66.f90
new file mode 100644
index 00000000000..d507eb62807
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_66.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Tests unlimited polymorphic function selectors in ASSOCIATE.
+!
+! Contributed by Harald Anlauf <anlauf@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" } }
diff --git a/gcc/testsuite/gfortran.dg/associate_67.f90 b/gcc/testsuite/gfortran.dg/associate_67.f90
new file mode 100644
index 00000000000..6bc3bc5f4d6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_67.f90
@@ -0,0 +1,41 @@
+! { dg-do run }
+!
+! Tests pointer function selectors in ASSOCIATE.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de> in
+! https://gcc.gnu.org/pipermail/fortran/2024-March/060294.html
+program paul
+ implicit none
+ type t
+ integer :: i
+ end type t
+ type(t), pointer :: p(:)
+ integer :: j
+ allocate (p(-3:3))
+ p% i = [(j,j=-3,3)]
+
+ associate (q => p)
+ print *, lbound (q), ubound (q) ! Should print -3 3 (OK)
+ print *, q% i
+ end associate
+
+ associate (q => set_ptr())
+ print *, lbound (q), ubound (q) ! Should print -3 3 (OK)
+ print *, q(:)% i ! <<< ... has no IMPLICIT type
+ end associate
+
+ associate (q => (p))
+ print *, lbound (q), ubound (q) ! Should print 1 7 (OK)
+ print *, q% i
+ end associate
+
+ associate (q => (set_ptr()))
+ print *, lbound (q), ubound (q) ! Should print 1 7 (OK)
+ print *, q(:)% i ! <<< ... has no IMPLICIT type
+ end associate
+contains
+ function set_ptr () result (res)
+ type(t), pointer :: res(:)
+ res => p
+ end function set_ptr
+end
diff --git a/gcc/testsuite/gfortran.dg/associate_68.f90 b/gcc/testsuite/gfortran.dg/associate_68.f90
new file mode 100644
index 00000000000..f05ecd8e26a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_68.f90
@@ -0,0 +1,79 @@
+! { dg-do run }
+! Test the fix for PR114280 in which inquiry references of associate names
+! of as yet unparsed function selectors failed.
+! Contributed by Steve Kargl <>
+program paul2
+ implicit none
+ type t
+ real :: re
+ end type t
+ real :: comp = 1, repart = 10, impart =100
+ call foo
+contains
+ subroutine foo ()
+ associate (x => bar1())
+! 'x' identified as complex from outset
+ if (int(x%im) .ne. 100) stop 1 ! Has no IMPLICIT type
+ if (int(x%re) .ne. 10) stop 2
+ end associate
+
+ associate (x => bar1())
+! 'x' identified as derived then corrected to complex
+ if (int(x%re) .ne. 11) stop 3 ! Has no IMPLICIT type
+ if (int(x%im) .ne. 101) stop 4
+ if (x%kind .ne. kind(1.0)) stop 5
+ end associate
+
+ associate (x => bar1())
+ if (x%kind .ne. kind(1.0)) stop 6 ! Invalid character in name
+ end associate
+
+ associate (x => bar2())
+ if (int(x%re) .ne. 1) stop 7 ! Invalid character in name
+ end associate
+
+ associate (xx => bar3())
+ if (xx%len .ne. 8) stop 8 ! Has no IMPLICIT type
+ if (trim (xx) .ne. "Nice one") stop 9
+ if (xx(6:8) .ne. "one") stop 10
+ end associate
+
+! Now check the array versions
+ associate (x => bar4())
+ if (any (int(abs (x(:) + 2.0)) .ne. [104,105])) stop 0
+ if (int(x(2)%re) .ne. 14) stop 11
+ if (any (int(x%im) .ne. [103,104])) stop 12
+ if (any (int(abs(x)) .ne. [103,104])) stop 13
+ end associate
+
+ associate (x => bar5())
+ if (x(:)%kind .ne. kind("A")) stop 14
+ if (x(2)%len .ne. 4) stop 15
+ if (x%len .ne. 4) stop 16
+ if (x(2)(1:3) .ne. "two") stop 17
+ if (any(x .ne. ["one ", "two "])) stop 18
+ end associate
+ end
+ complex function bar1 ()
+ bar1 = cmplx(repart, impart)
+ repart = repart + 1
+ impart = impart + 1
+ end
+ type(t) function bar2 ()
+ bar2% re = comp
+ comp = comp + 1
+ end
+ character(8) function bar3 ()
+ bar3 = "Nice one!"
+ end
+ function bar4 () result (res)
+ complex, allocatable, dimension(:) :: res
+ res = [cmplx(repart, impart),cmplx(repart+1, impart+1)]
+ repart = repart + 2
+ impart = impart + 2
+ end
+ function bar5 () result (res)
+ character(4), allocatable, dimension(:) :: res
+ res = ["one ", "two "]
+ end
+end
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-03-15 6:53 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-03-15 6:53 [gcc r14-9489] Fortran: Fix class/derived/complex function associate selectors [PR87477] Paul Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).