From 371b334e65a898cd795259aebfd60b27d3b963b9 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Wed, 5 May 2010 09:44:33 +0200 Subject: [PATCH] re PR fortran/43696 ([OOP] Bogus error: Passed-object dummy argument must not be POINTER) 2010-05-05 Janus Weil PR fortran/43696 * resolve.c (resolve_fl_derived): Some fixes for class variables. * symbol.c (gfc_build_class_symbol): Add separate class container for class pointers. 2010-05-05 Janus Weil PR fortran/43696 * gfortran.dg/class_17.f03: New. From-SVN: r159056 --- gcc/fortran/ChangeLog | 7 +++ gcc/fortran/resolve.c | 14 +++++- gcc/fortran/symbol.c | 2 + gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/class_17.f03 | 64 ++++++++++++++++++++++++++ 5 files changed, 90 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_17.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e61c7371110..0641cbfab67 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2010-05-05 Janus Weil + + PR fortran/43696 + * resolve.c (resolve_fl_derived): Some fixes for class variables. + * symbol.c (gfc_build_class_symbol): Add separate class container for + class pointers. + 2010-05-03 Steven G. Kargl PR fortran/43592 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 93c5b484ce0..d92c69c030c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10794,7 +10794,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ - if (super_type + if (super_type && !sym->attr.is_class && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { gfc_error ("Component '%s' of '%s' at %L has the same name as an" @@ -10841,7 +10841,7 @@ resolve_fl_derived (gfc_symbol *sym) } } - if (c->ts.type == BT_DERIVED && c->attr.pointer + if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer && c->ts.u.derived->components == NULL && !c->ts.u.derived->attr.zero_comp) { @@ -10851,6 +10851,16 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } + if (c->ts.type == BT_CLASS && c->ts.u.derived->components->attr.pointer + && c->ts.u.derived->components->ts.u.derived->components == NULL + && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp) + { + gfc_error ("The pointer component '%s' of '%s' at %L is a type " + "that has not been declared", c->name, sym->name, + &c->loc); + return FAILURE; + } + /* C437. */ if (c->ts.type == BT_CLASS && !(c->ts.u.derived->components->attr.pointer diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index b19714cfca6..8403578b81e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4720,6 +4720,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); else if ((*as) && (*as)->rank) sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); + else if (attr->pointer) + sprintf (name, ".class.%s.p", ts->u.derived->name); else if (attr->allocatable) sprintf (name, ".class.%s.a", ts->u.derived->name); else diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 655afcd66b5..f8273f07046 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-05-05 Janus Weil + + PR fortran/43696 + * gfortran.dg/class_17.f03: New. + 2010-05-04 Mike Stump PR objc/35165 diff --git a/gcc/testsuite/gfortran.dg/class_17.f03 b/gcc/testsuite/gfortran.dg/class_17.f03 new file mode 100644 index 00000000000..b015c1319f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_17.f03 @@ -0,0 +1,64 @@ +! { dg-do compile } +! +! PR 43696: [OOP] Bogus error: Passed-object dummy argument must not be POINTER +! +! Contributed by Hans-Werner Boschmann + + +MODULE error_stack_module + implicit none + + type,abstract::serializable_class + contains + procedure(ser_DTV_RF),deferred::read_formatted + end type serializable_class + + abstract interface + subroutine ser_DTV_RF(dtv,unit,iotype,v_list,iostat,iomsg) + import serializable_class + CLASS(serializable_class),INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + end subroutine ser_DTV_RF + end interface + + type,extends(serializable_class)::error_type + class(error_type),pointer::next=>null() + contains + procedure::read_formatted=>error_read_formatted + end type error_type + +contains + + recursive subroutine error_read_formatted(dtv,unit,iotype,v_list,iostat,iomsg) + CLASS(error_type),INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + character(8),allocatable::type + character(8),allocatable::next + call basic_read_string(unit,type) + call basic_read_string(unit,next) + if(next=="NEXT")then + allocate(dtv%next) + call dtv%next%read_formatted(unit,iotype,v_list,iostat,iomsg) + end if + end subroutine error_read_formatted + +end MODULE error_stack_module + + +module b_module + implicit none + type::b_type + class(not_yet_defined_type_type),pointer::b_component ! { dg-error "is a type that has not been declared" } + end type b_type +end module b_module + + +! { dg-final { cleanup-modules "error_stack_module b_module" } } -- 2.30.2