p = gfc_copy_expr (*expr);
if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
gfc_replace_expr (*expr, p);
+ else
+ gfc_free_expr (p);
if ((*expr)->expr_type == EXPR_FUNCTION)
{
}
+bool
+gfc_is_ptr_fcn (gfc_expr *e)
+{
+ return e != NULL && e->expr_type == EXPR_FUNCTION
+ && (gfc_expr_attr (e).pointer
+ || (e->ts.type == BT_CLASS
+ && CLASS_DATA (e)->attr.class_pointer));
+}
+
+
/* Copy a shape array. */
mpz_t *
}
return false;
}
+ else if (context && gfc_is_ptr_fcn (assoc->target))
+ {
+ if (!gfc_notify_std (GFC_STD_F2018, "%qs at %L associated to "
+ "pointer function target being used in a "
+ "variable definition context (%s)", name,
+ &e->where, context))
+ return false;
+ else if (gfc_has_vector_index (e))
+ {
+ gfc_error ("%qs at %L associated to vector-indexed target"
+ " cannot be used in a variable definition"
+ " context (%s)",
+ name, &e->where, context);
+ return false;
+ }
+ }
/* Target must be allowed to appear in a variable definition context. */
if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
bool gfc_simplify_expr (gfc_expr *, int);
bool gfc_try_simplify_expr (gfc_expr *, int);
bool gfc_has_vector_index (gfc_expr *);
+bool gfc_is_ptr_fcn (gfc_expr *);
gfc_expr *gfc_get_expr (void);
gfc_expr *gfc_get_array_expr (bt type, int kind, locus *);
}
+/* Build the associate name */
+static int
+build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2)
+{
+ gfc_expr *expr1 = *e1;
+ gfc_expr *expr2 = *e2;
+ gfc_symbol *sym;
+
+ /* For the case where the associate name is already an associate name. */
+ if (!expr2)
+ expr2 = expr1;
+ expr1 = gfc_get_expr ();
+ expr1->expr_type = EXPR_VARIABLE;
+ expr1->where = expr2->where;
+ if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
+ return 1;
+
+ sym = expr1->symtree->n.sym;
+ if (expr2->ts.type == BT_UNKNOWN)
+ sym->attr.untyped = 1;
+ else
+ copy_ts_from_selector_to_associate (expr1, expr2);
+
+ sym->attr.flavor = FL_VARIABLE;
+ sym->attr.referenced = 1;
+ sym->attr.class_ok = 1;
+
+ *e1 = expr1;
+ *e2 = expr2;
+ return 0;
+}
+
+
/* Push the current selector onto the SELECT TYPE stack. */
static void
match m;
char name[GFC_MAX_SYMBOL_LEN + 1];
bool class_array;
- gfc_symbol *sym;
gfc_namespace *ns = gfc_current_ns;
m = gfc_match_label ();
m = gfc_match (" %n => %e", name, &expr2);
if (m == MATCH_YES)
{
- expr1 = gfc_get_expr ();
- expr1->expr_type = EXPR_VARIABLE;
- expr1->where = expr2->where;
- if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
+ if (build_associate_name (name, &expr1, &expr2))
{
m = MATCH_ERROR;
goto cleanup;
}
-
- sym = expr1->symtree->n.sym;
- if (expr2->ts.type == BT_UNKNOWN)
- sym->attr.untyped = 1;
- else
- copy_ts_from_selector_to_associate (expr1, expr2);
-
- sym->attr.flavor = FL_VARIABLE;
- sym->attr.referenced = 1;
- sym->attr.class_ok = 1;
}
else
{
goto cleanup;
}
+ /* Prevent an existing associate name from reuse here by pushing expr1 to
+ expr2 and building a new associate name. */
+ if (!expr2 && expr1->symtree->n.sym->assoc
+ && !expr1->symtree->n.sym->attr.select_type_temporary
+ && !expr1->symtree->n.sym->attr.select_rank_temporary
+ && build_associate_name (expr1->symtree->n.sym->name, &expr1, &expr2))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr1;
new_st.expr2 = expr2;
gcc_assert (sym->ts.type != BT_UNKNOWN);
/* See if this is a valid association-to-variable. */
- sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
- && !parentheses
- && !gfc_has_vector_subscript (target));
+ sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE
+ && !parentheses
+ && !gfc_has_vector_subscript (target))
+ || gfc_is_ptr_fcn (target));
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)
&& !(sym->attr.use_assoc && !intrinsic_array_parameter)))
gfc_defer_symbol_init (sym);
+ /* Set the vptr of unlimited polymorphic pointer variables so that
+ they do not cause segfaults in select type, when the selector
+ is an intrinsic type. Arrays are captured above. */
+ if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
+ && CLASS_DATA (sym)->attr.class_pointer
+ && !CLASS_DATA (sym)->attr.dimension && !sym->attr.dummy
+ && sym->attr.flavor == FL_VARIABLE && !sym->assoc)
+ gfc_defer_symbol_init (sym);
+
if (sym->ts.type == BT_CHARACTER
&& sym->attr.allocatable
&& !sym->attr.dimension
gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
}
+
gfc_finish_var_decl (decl, sym);
if (sym->ts.type == BT_CHARACTER)
if (sym->assoc)
continue;
+ /* Set the vptr of unlimited polymorphic pointer variables so that
+ they do not cause segfaults in select type, when the selector
+ is an intrinsic type. */
+ if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
+ && sym->attr.flavor == FL_VARIABLE && !sym->assoc
+ && !sym->attr.dummy && CLASS_DATA (sym)->attr.class_pointer)
+ {
+ gfc_symbol *vtab;
+ gfc_init_block (&tmpblock);
+ vtab = gfc_find_vtab (&sym->ts);
+ if (!vtab->backend_decl)
+ {
+ if (!vtab->attr.referenced)
+ gfc_set_sym_referenced (vtab);
+ gfc_get_symbol_decl (vtab);
+ }
+ tmp = gfc_class_vptr_get (sym->backend_decl);
+ gfc_add_modify (&tmpblock, tmp,
+ gfc_build_addr_expr (TREE_TYPE (tmp),
+ vtab->backend_decl));
+ gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
+ }
+
if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived
&& sym->ts.u.derived->attr.pdt_type)
tree ctree = gfc_get_class_from_expr (se.expr);
tmp = TREE_TYPE (sym->backend_decl);
- /* Coarray scalar component expressions can emerge from
- the front end as array elements of the _data field. */
+ /* F2018:19.5.1.6 "If a selector has the POINTER attribute,
+ it shall be associated; the associate name is associated
+ with the target of the pointer and does not have the
+ POINTER attribute." */
if (sym->ts.type == BT_CLASS
- && e->ts.type == BT_CLASS && e->rank == 0
- && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree)
+ && e->ts.type == BT_CLASS && e->rank == 0 && ctree
+ && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))
+ || CLASS_DATA (e)->attr.class_pointer))
{
tree stmp;
tree dtmp;
ctree = gfc_create_var (dtmp, "class");
stmp = gfc_class_data_get (se.expr);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)));
-
- /* Set the fields of the target class variable. */
- stmp = gfc_conv_descriptor_data_get (stmp);
+ /* 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);
dtmp = gfc_class_data_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
dtmp = gfc_class_len_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
+ need_len_assign = false;
}
se.expr = ctree;
}
--- /dev/null
+! { dg-do run }
+!
+! Contributed by Karl Kaiser <kaiserkarl31@yahoo.com>
+!
+program test
+
+ class(*), pointer :: ptr1, ptr2(:)
+ integer, target :: i = 42
+ integer :: check = 0
+! First with associate name and no selector in select types
+ associate (c => ptr1)
+ select type (c) ! Segfault - vptr not set
+ type is (integer)
+ stop 1
+ class default
+ check = 1
+ end select
+ end associate
+! Now do the same with the array version
+ associate (c => ptr2)
+ select type (d =>c) ! Segfault - vptr not set
+ type is (integer)
+ stop 2
+ class default
+ check = check + 10
+ end select
+ end associate
+
+! And now with the associate name and selector
+ associate (c => ptr1)
+ select type (d => c) ! Segfault - vptr not set
+ type is (integer)
+ stop 3
+ class default
+ check = check + 100
+ end select
+ end associate
+! Now do the same with the array version
+! ptr2 => NULL() !This did not fix the problem
+ associate (c => ptr2)
+ select type (d => c) ! Segfault - vptr not set
+ type is (integer)
+ stop 4
+ class default
+ check = check + 1000
+ end select
+ end associate
+ if (check .ne. 1111) stop 5
+end program test
--- /dev/null
+! { dg-do compile }
+!
+! Contributed by Neil Carlson <neil.n.carlson@gmail.com>
+!
+module mod
+ type :: foo
+ real, pointer :: var
+ contains
+ procedure :: var_ptr
+ end type
+contains
+ function var_ptr(this) result(ref)
+ class(foo) :: this
+ real, pointer :: ref
+ ref => this%var
+ end function
+end module
+program main
+ use mod
+ type(foo) :: x
+ allocate (x%var, source = 2.0)
+ associate (var => x%var_ptr())
+ var = 1.0
+ end associate
+ if (x%var .ne. 1.0) stop 1
+ x%var_ptr() = 2.0
+ if (x%var .ne. 2.0) stop 2
+ deallocate (x%var)
+end program
--- /dev/null
+! { dg-do run }
+!
+! Contributed by Thomas Fanning <thfanning@gmail.com>
+!
+!
+module mod
+
+ type test
+ class(*), pointer :: ptr
+ contains
+ procedure :: setref
+ end type
+
+contains
+
+ subroutine setref(my,ip)
+ implicit none
+ class(test) :: my
+ integer, pointer :: ip
+ my%ptr => ip
+ end subroutine
+
+ subroutine set7(ptr)
+ implicit none
+ class(*), pointer :: ptr
+ select type (ptr)
+ type is (integer)
+ ptr = 7
+ end select
+ end subroutine
+
+end module
+!---------------------------------------
+
+!---------------------------------------
+program bug
+use mod
+implicit none
+
+ integer, pointer :: i, j
+ type(test) :: tp
+ class(*), pointer :: lp
+
+ allocate(i,j)
+ i = 3; j = 4
+
+ call tp%setref(i)
+ select type (ap => tp%ptr)
+ class default
+ call tp%setref(j)
+ lp => ap
+ call set7(lp)
+ end select
+
+! gfortran used to give i=3 and j=7 because the associate name was not pointing
+! to the target of tp%ptr as required by F2018:19.5.1.6 but, rather, to the
+! selector itself.
+ if (i .ne. 7) stop 1
+ if (j .ne. 4) stop 2
+
+end program
+!---------------------------------------
--- /dev/null
+! { dg-do compile }
+!
+! Contributed by Vladimir Nikishkin <lockywolf@gmail.com>
+!
+module test
+ type testtype
+ class(*), allocatable :: t
+ end type testtype
+contains
+ subroutine testproc( x )
+ class(testtype) :: x
+ associate ( temp => x%t)
+ select type (temp)
+ type is (integer)
+ end select
+ end associate
+ end subroutine testproc
+end module test
! { dg-do compile }
+! { dg-options "-std=f2008" }
+
program test
implicit none
end
-! { dg-error "cannot be used in a variable definition context .assignment." " " { target *-*-* } 21 }
-! { dg-error "cannot be used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 23 }
-! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 35 }
+! { dg-error "being used in a variable definition context .assignment." " " { target *-*-* } 23 }
+! { dg-error "being used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 25 }
! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 37 }
+! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 39 }
git://gcc.gnu.org / gcc.git / commitdiff