+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
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);
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;
}
-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)
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)
{
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)
}
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);
+
+ 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;
- *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
- formatted);
+ 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;
+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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff