2019-08-03 Thomas Koenig <tkoenig@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
Backport from trunk
PR fortran/90786
PR fortran/90813
* trans-expr.c (pointer_assignment_is_proc_pointer) Remove as
it is very simple and only called from one place.
(gfc_trans_pointer_assignment): Rename non_proc_pointer_assign
as non_proc_ptr_assign. Assign to it directly, rather than call
to above, deleted function and use gfc_expr_attr instead of
only checking the reference chain.
* trans-decl.c (sym_identifier): New function.
(mangled_identifier): New function, doing most of the work
of gfc_sym_mangled_identifier.
(gfc_sym_mangled_identifier): Use mangled_identifier. Add mangled
identifier to global symbol table.
(get_proc_pointer_decl): Use backend decl from global identifier
if present.
2019-08-03 Thomas Koenig <tkoenig@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
Backport from trunk
PR fortran/90786
PR fortran/90813
* gfortran.dg/proc_ptr_51.f90: New test.
Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>
From-SVN: r274038
+2019-08-03 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90786
+ PR fortran/90813
+ * trans-expr.c (pointer_assignment_is_proc_pointer) Remove as
+ it is very simple and only called from one place.
+ (gfc_trans_pointer_assignment): Rename non_proc_pointer_assign
+ as non_proc_ptr_assign. Assign to it directly, rather than call
+ to above, deleted function and use gfc_expr_attr instead of
+ only checking the reference chain.
+ * trans-decl.c (sym_identifier): New function.
+ (mangled_identifier): New function, doing most of the work
+ of gfc_sym_mangled_identifier.
+ (gfc_sym_mangled_identifier): Use mangled_identifier. Add mangled
+ identifier to global symbol table.
+ (get_proc_pointer_decl): Use backend decl from global identifier
+ if present.
+
2019-06-21 Thomas Koenig <tkoenig@gcc.gnu.org>
Backport from trunk
}
}
+/* Return the name of an identifier. */
-/* Convert a gfc_symbol to an identifier of the same name. */
-
-static tree
-gfc_sym_identifier (gfc_symbol * sym)
+static const char *
+sym_identifier (gfc_symbol *sym)
{
if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
- return (get_identifier ("MAIN__"));
+ return "MAIN__";
else
- return (get_identifier (sym->name));
+ return sym->name;
}
-
-/* Construct mangled name from symbol name. */
+/* Convert a gfc_symbol to an identifier of the same name. */
static tree
-gfc_sym_mangled_identifier (gfc_symbol * sym)
+gfc_sym_identifier (gfc_symbol * sym)
{
- char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ return get_identifier (sym_identifier (sym));
+}
+/* Construct mangled name from symbol name. */
+
+static const char *
+mangled_identifier (gfc_symbol *sym)
+{
+ static char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
/* Prevent the mangling of identifiers that have an assigned
binding label (mainly those that are bind(c)). */
+
if (sym->attr.is_bind_c == 1 && sym->binding_label)
- return get_identifier (sym->binding_label);
+ return sym->binding_label;
if (!sym->fn_result_spec)
{
if (sym->module == NULL)
- return gfc_sym_identifier (sym);
+ return sym_identifier (sym);
else
{
snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
- return get_identifier (name);
+ return name;
}
}
else
sym->ns->proc_name->module,
sym->ns->proc_name->name,
sym->name);
- return get_identifier (name);
+ return name;
}
else
{
snprintf (name, sizeof name, "__%s_PROC_%s",
sym->ns->proc_name->name, sym->name);
- return get_identifier (name);
+ return name;
}
}
}
+/* Get mangled identifier, adding the symbol to the global table if
+ it is not yet already there. */
+
+static tree
+gfc_sym_mangled_identifier (gfc_symbol * sym)
+{
+ tree result;
+ gfc_gsymbol *gsym;
+ const char *name;
+
+ name = mangled_identifier (sym);
+ result = get_identifier (name);
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (gsym == NULL)
+ {
+ gsym = gfc_get_gsymbol (name, false);
+ gsym->ns = sym->ns;
+ gsym->sym_name = sym->name;
+ }
+
+ return result;
+}
/* Construct mangled function name from symbol name. */
tree decl;
tree attributes;
+ if (sym->module || sym->fn_result_spec)
+ {
+ const char *name;
+ gfc_gsymbol *gsym;
+
+ name = mangled_identifier (sym);
+ gsym = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (gsym != NULL)
+ {
+ gfc_symbol *s;
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ if (s && s->backend_decl)
+ return s->backend_decl;
+ }
+ }
+
decl = sym->backend_decl;
if (decl)
return decl;
}
}
-/* Indentify class valued proc_pointer assignments. */
-
-static bool
-pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
-{
- gfc_ref * ref;
-
- ref = expr1->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- return ref && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
-}
-
/* Do everything that is needed for a CLASS function expr2. */
tree tmp;
tree decl;
tree expr1_vptr = NULL_TREE;
- bool scalar, non_proc_pointer_assign;
+ bool scalar, non_proc_ptr_assign;
gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
- non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+ non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
+ && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
else
gfc_conv_expr (&rse, expr2);
- if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+ if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
NULL);
+2019-08-03 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90786
+ PR fortran/90813
+ * gfortran.dg/proc_ptr_51.f90: New test.
+
2019-07-22 Martin Liska <mliska@suse.cz>
Backport from mainline
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR90786.
+!
+! Contributed by Andrew benson <abensonca@gmail.com>
+!
+module f
+procedure(c), pointer :: c_
+
+ type :: s
+ integer :: i = 42
+ end type s
+ class(s), pointer :: res, tgt
+
+contains
+
+ function c()
+ implicit none
+ class(s), pointer :: c
+ c => tgt
+ return
+ end function c
+
+ subroutine fs()
+ implicit none
+ c_ => c ! This used to ICE
+ return
+ end subroutine fs
+
+end module f
+
+ use f
+ allocate (tgt, source = s(99))
+ call fs()
+ res => c_()
+ if (res%i .ne. 99) stop 1
+ deallocate (tgt)
+end
projects / thirdparty / gcc.git / commitdiff
