The attach patch has lived in my tree for 4 months.
It's time to submit it. Passed regression testing
for a long time.
An INTENT(in) entity that has CLASS(*) dummy argument
should not use SELECT TYPE to then try to assign to the
entity. OK to commit?
2019-06-12 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/89344
* expr.c (gfc_check_vardef_context): Check for INTENT(IN) variable
in SELECT TYPE construct.
2019-06-12 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/89344
* gfortran.dg/pr89344.f90: New test.
--
Steve
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 270774)
+++ gcc/fortran/expr.c (working copy)
@@ -6086,7 +6095,12 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, b
check_intentin = false;
}
}
- if (check_intentin && sym->attr.intent == INTENT_IN)
+
+ if (check_intentin
+ && (sym->attr.intent == INTENT_IN
+ || (sym->attr.select_type_temporary && sym->assoc
+ && sym->assoc->target && sym->assoc->target->symtree
+ && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN)))
{
if (pointer && is_pointer)
{
@@ -6098,10 +6112,12 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, b
}
if (!pointer && !is_pointer && !sym->attr.pointer)
{
+ const char *name = sym->attr.select_type_temporary
+ ? sym->assoc->target->symtree->name : sym->name;
if (context)
gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
" definition context (%s) at %L",
- sym->name, context, &e->where);
+ name, context, &e->where);
return false;
}
}
Index: /safe/sgk/gcc/gccx/gcc/testsuite/gfortran.dg/pr89344.f90
===================================================================
--- /safe/sgk/gcc/gccx/gcc/testsuite/gfortran.dg/pr89344.f90 (nonexistent)
+++ /safe/sgk/gcc/gccx/gcc/testsuite/gfortran.dg/pr89344.f90 (working copy)
@@ -0,0 +1,15 @@
+! { dg-do compile }
+program demo_setval
+ call setval(value)
+ write(*,*)'VALUE=',value
+ contains
+ subroutine setval(value)
+ class(*),intent(in) :: value
+ select type(value)
+ type is (integer)
+ value = 10 ! { dg-error "in variable definition context" }
+ type is (real)
+ value = 10.20 ! { dg-error "in variable definition context" }
+ end select
+ end subroutine setval
+end program demo_setval
