OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/78737 ([OOP] linking error with deferred, undefined user-defined derived-type I/O)

Browse Source 
2016-12-13  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78737
	* gfortran.h (gfc_find_typebound_dtio_proc): New prototype.
	* interface.c (gfc_compare_interfaces): Whitespace fix.
	(gfc_find_typebound_dtio_proc): New function.
	(gfc_find_specific_dtio_proc): Use it. Improve error recovery.
	* trans-io.c (get_dtio_proc): Implement polymorphic calls to DTIO
	procedures.

2016-12-13  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78737
	* gfortran.dg/dtio_19.f90: New test case.

Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>

From-SVN: r243609
This commit is contained in:
Janus Weil 2016-12-13 15:28:17 +01:00
parent 68a08b7792
commit e4e659b947
6 changed files with 136 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/ChangeLog
View File

@ -1,3 +1,14 @@
2016-12-13 Janus Weil <janus@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/78737
* gfortran.h (gfc_find_typebound_dtio_proc): New prototype.
* interface.c (gfc_compare_interfaces): Whitespace fix.
(gfc_find_typebound_dtio_proc): New function.
(gfc_find_specific_dtio_proc): Use it. Improve error recovery.
* trans-io.c (get_dtio_proc): Implement polymorphic calls to DTIO
procedures.
2016-12-12 Janus Weil <janus@gcc.gnu.org>
PR fortran/78392

1
gcc/fortran/gfortran.h
View File

@ -3252,6 +3252,7 @@ int gfc_has_vector_subscript (gfc_expr*);
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
void gfc_check_dtio_interfaces (gfc_symbol*);
gfc_symtree* gfc_find_typebound_dtio_proc (gfc_symbol *, bool, bool);
gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool);

32
gcc/fortran/interface.c
View File

@ -1712,8 +1712,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
return 0;
/* Special case: alternate returns. If both f1->sym and f2->sym are
NULL, then the leading formal arguments are alternate returns.
The previous conditional should catch argument lists with
NULL, then the leading formal arguments are alternate returns.
The previous conditional should catch argument lists with
different number of argument. */
if (f1 && f1->sym == NULL && f2 && f2->sym == NULL)
return 1;
@ -4826,13 +4826,10 @@ gfc_check_dtio_interfaces (gfc_symbol *derived)
}
gfc_symbol *
gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
gfc_symtree*
gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
{
gfc_symtree *tb_io_st = NULL;
gfc_symbol *dtio_sub = NULL;
gfc_symbol *extended;
gfc_typebound_proc *tb_io_proc, *specific_proc;
bool t = false;
if (!derived || derived->attr.flavor != FL_DERIVED)
@ -4869,6 +4866,19 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
true,
&derived->declared_at);
}
return tb_io_st;
}
gfc_symbol *
gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
{
gfc_symtree *tb_io_st = NULL;
gfc_symbol *dtio_sub = NULL;
gfc_symbol *extended;
gfc_typebound_proc *tb_io_proc, *specific_proc;
tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted);
if (tb_io_st != NULL)
{
@ -4893,17 +4903,17 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
dtio_sub = st->n.tb->u.specific->n.sym;
else
dtio_sub = specific_proc->u.specific->n.sym;
}
if (tb_io_st != NULL)
goto finish;
goto finish;
}
/* If there is not a typebound binding, look for a generic
DTIO interface. */
for (extended = derived; extended;
extended = gfc_get_derived_super_type (extended))
{
if (extended == NULL || extended->ns == NULL)
if (extended == NULL || extended->ns == NULL
|| extended->attr.flavor == FL_UNKNOWN)
return NULL;
if (formatted == true)

36
gcc/fortran/trans-io.c
View File

@ -2181,15 +2181,37 @@ get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
}
if (ts->type == BT_DERIVED)
derived = ts->u.derived;
else
derived = ts->u.derived->components->ts.u.derived;
{
derived = ts->u.derived;
*dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
formatted);
*dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
formatted);
if (*dtio_sub)
return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
}
else if (ts->type == BT_CLASS)
{
gfc_symtree *tb_io_st;
derived = ts->u.derived->components->ts.u.derived;
tb_io_st = gfc_find_typebound_dtio_proc (derived,
last_dt == WRITE, formatted);
if (tb_io_st)
{
gfc_se se;
gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
gfc_add_vptr_component (expr);
gfc_add_component_ref (expr,
tb_io_st->n.tb->u.generic->specific_st->name);
*dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
gfc_free_expr (expr);
return se.expr;
}
}
if (*dtio_sub)
return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
return NULL_TREE;

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2016-12-13 Janus Weil <janus@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/78737
* gfortran.dg/dtio_19.f90: New test case.
2016-12-13 Michael Matz <matz@suse.de>
PR tree-optimization/78725

68
gcc/testsuite/gfortran.dg/dtio_19.f90 Normal file
View File

@ -0,0 +1,68 @@
! { dg-do run }
!
! PR78737: [OOP] linking error with deferred, undefined user-defined derived-type I/O
!
! Contributed by Damian Rouson <damian@sourceryinstitute.org>
module object_interface
character(30) :: buffer(2)
type, abstract :: object
contains
procedure(write_formatted_interface), deferred :: write_formatted
generic :: write(formatted) => write_formatted
end type
abstract interface
subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg)
import object
class(object), intent(in) :: this
integer, intent(in) :: unit
character (len=*), intent(in) :: iotype
integer, intent(in) :: vlist(:)
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
end subroutine
end interface
type, extends(object) :: non_abstract_child1
integer :: i
contains
procedure :: write_formatted => write_formatted1
end type
type, extends(object) :: non_abstract_child2
real :: r
contains
procedure :: write_formatted => write_formatted2
end type
contains
subroutine write_formatted1(this,unit,iotype,vlist,iostat,iomsg)
class(non_abstract_child1), intent(in) :: this
integer, intent(in) :: unit
character (len=*), intent(in) :: iotype
integer, intent(in) :: vlist(:)
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
write(unit,'(a,i2/)') "write_formatted1 => ", this%i
end subroutine
subroutine write_formatted2(this,unit,iotype,vlist,iostat,iomsg)
class(non_abstract_child2), intent(in) :: this
integer, intent(in) :: unit
character (len=*), intent(in) :: iotype
integer, intent(in) :: vlist(:)
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
write(unit,'(a,f4.1/)') "write_formatted2 => ", this%r
end subroutine
subroutine assert(a)
class(object):: a
write(buffer,'(DT)') a
end subroutine
end module
program p
use object_interface
call assert (non_abstract_child1 (99))
if (trim (buffer(1)) .ne. "write_formatted1 => 99") call abort
call assert (non_abstract_child2 (42.0))
if (trim (buffer(1)) .ne. "write_formatted2 => 42.0") call abort
end