+2009-08-10 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40940
+ * decl.c (gfc_match_type_spec): Match CLASS statement and warn about
+ missing polymorphism.
+ * gfortran.h (gfc_typespec): Add field 'is_class'.
+ * misc.c (gfc_clear_ts): Initialize 'is_class' to zero.
+ * resolve.c (type_is_extensible): New function to check if a derived
+ type is extensible.
+ (resolve_fl_variable_derived): Add error checks for CLASS variables.
+ (resolve_typebound_procedure): Disallow non-polymorphic passed-object
+ dummy arguments, turning warning into error.
+ (resolve_fl_derived): Use 'type_is_extensible'. Disallow non-polymorphic
+ passed-object dummy arguments for procedure pointer components,
+ turning warning into error. Add error check for CLASS components.
+
2009-08-05 Tobias Burnus <burnus@net-b.de>
PR fortran/40955
m = gfc_match (" type ( %n )", name);
if (m != MATCH_YES)
- return m;
+ {
+ m = gfc_match (" class ( %n )", name);
+ if (m != MATCH_YES)
+ return m;
+ ts->is_class = 1;
+
+ /* TODO: Implement Polymorphism. */
+ gfc_warning ("Polymorphic entities are not yet implemented. "
+ "CLASS will be treated like TYPE at %C");
+ }
ts->type = BT_DERIVED;
struct gfc_symbol *derived;
gfc_charlen *cl; /* For character types only. */
struct gfc_symbol *interface; /* For PROCEDURE declarations. */
+ unsigned int is_class:1;
int is_c_interop;
int is_iso_c;
bt f90_type;
ts->kind = 0;
ts->cl = NULL;
ts->interface = NULL;
+ ts->is_class = 0;
/* flag that says if the type is C interoperable */
ts->is_c_interop = 0;
/* says what f90 type the C kind interops with */
}
+/* Check if a derived type is extensible. */
+
+static bool
+type_is_extensible (gfc_symbol *sym)
+{
+ return !(sym->attr.is_bind_c || sym->attr.sequence);
+}
+
+
/* Additional checks for symbols with flavor variable and derived
type. To be called from resolve_fl_variable. */
return FAILURE;
}
+ if (sym->ts.is_class)
+ {
+ /* C502. */
+ if (!type_is_extensible (sym->ts.derived))
+ {
+ gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
+ sym->ts.derived->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ /* C509. */
+ if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
+ {
+ gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
+ "or pointer", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
/* Assign default initializer. */
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
goto error;
}
- gfc_warning ("Polymorphic entities are not yet implemented,"
- " non-polymorphic passed-object dummy argument of '%s'"
- " at %L accepted", proc->name, &where);
+ if (!me_arg->ts.is_class)
+ {
+ gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+ " at %L", proc->name, &where);
+ goto error;
+ }
}
/* If we are extending some type, check that we don't override a procedure
return FAILURE;
/* An ABSTRACT type must be extensible. */
- if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
+ if (sym->attr.abstract && !type_is_extensible (sym))
{
gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
sym->name, &sym->declared_at);
return FAILURE;
}
- /* TODO: Make this an error once CLASS is implemented. */
- if (!sym->attr.sequence)
- gfc_warning ("Polymorphic entities are not yet implemented,"
- " non-polymorphic passed-object dummy argument of '%s'"
- " at %L accepted", c->name, &c->loc);
+ if (type_is_extensible (sym) && !me_arg->ts.is_class)
+ gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+ " at %L", c->name, &c->loc);
}
return FAILURE;
}
+ /* C437. */
+ if (c->ts.type == BT_DERIVED && c->ts.is_class
+ && !(c->attr.pointer || c->attr.allocatable))
+ {
+ gfc_error ("Component '%s' with CLASS at %L must be allocatable "
+ "or pointer", c->name, &c->loc);
+ return FAILURE;
+ }
+
/* Ensure that all the derived type components are put on the
derived type list; even in formal namespaces, where derived type
pointer components might not have been declared. */
+2009-08-10 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40940
+ * gfortran.dg/class_1.f03: New.
+ * gfortran.dg/class_2.f03: New.
+ * gfortran.dg/proc_ptr_comp_pass_1.f90: Use CLASS instead of TYPE.
+ * gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto.
+ * gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto.
+ * gfortran.dg/typebound_call_10.f03: Ditto.
+ * gfortran.dg/typebound_call_2.f03: Ditto.
+ * gfortran.dg/typebound_call_3.f03: Ditto.
+ * gfortran.dg/typebound_call_4.f03: Ditto.
+ * gfortran.dg/typebound_generic_3.f03: Ditto.
+ * gfortran.dg/typebound_generic_4.f03: Ditto.
+ * gfortran.dg/typebound_proc_1.f08: Ditto.
+ * gfortran.dg/typebound_proc_5.f03: Ditto.
+ * gfortran.dg/typebound_proc_6.f03: Ditto.
+
2009-08-10 Dodji Seketeli <dodji@redhat.com>
PR c++/40866
--- /dev/null
+! { dg-do run }
+!
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+!
+! PR 40940: CLASS statement
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+implicit none
+
+type t
+ integer :: comp
+ class(t),pointer :: c2
+end type
+
+class(t),pointer :: c1
+
+allocate(c1)
+
+c1%comp = 5
+c1%c2 => c1
+
+print *,c1%comp
+
+call sub(c1)
+
+if (c1%comp/=5) call abort()
+
+deallocate(c1)
+
+contains
+
+ subroutine sub (c3)
+ class(t) :: c3
+ print *,c3%comp
+ end subroutine
+
+end
+
--- /dev/null
+! { dg-do compile }
+!
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+!
+! PR 40940: CLASS statement
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+use,intrinsic :: iso_c_binding
+
+type t1
+ integer :: comp
+end type
+
+type t2
+ sequence
+ real :: r
+end type
+
+type,bind(c) :: t3
+ integer(c_int) :: i
+end type
+
+type :: t4
+ procedure(absint), pointer :: p ! { dg-error "Non-polymorphic passed-object dummy argument" }
+end type
+
+type :: t5
+ class(t1) :: c ! { dg-error "must be allocatable or pointer" }
+end type
+
+abstract interface
+ subroutine absint(arg)
+ import :: t4
+ type(t4) :: arg
+ end subroutine
+end interface
+
+
+class(t1) :: o1 ! { dg-error "must be dummy, allocatable or pointer" }
+
+class(t2), pointer :: o2 ! { dg-error "is not extensible" }
+class(t3), pointer :: o3 ! { dg-error "is not extensible" }
+
+end
+
abstract interface
subroutine set_int_value(this,i)
import
- type(mytype), intent(inout) :: this
+ class(mytype), intent(inout) :: this
integer, intent(in) :: i
end subroutine set_int_value
end interface
contains
subroutine seti_proc(this,i)
- type(mytype), intent(inout) :: this
+ class(mytype), intent(inout) :: this
integer, intent(in) :: i
this%i=i
end subroutine seti_proc
contains
subroutine print_me (arg, lun)
- type(t), intent(in) :: arg
+ class(t), intent(in) :: arg
integer, intent(in) :: lun
if (abs(arg%a-2.718)>1E-6) call abort()
write (lun,*) arg%a
end subroutine print_me
subroutine print_my_square (arg, lun)
- type(t), intent(in) :: arg
+ class(t), intent(in) :: arg
integer, intent(in) :: lun
if (abs(arg%a-2.718)>1E-6) call abort()
write (lun,*) arg%a**2
subroutine obp(w,x)
import :: t
integer :: w
- type(t) :: x
+ class(t) :: x
end subroutine
end interface
subroutine my_obp_sub(w,x)
integer :: w
- type(t) :: x
+ class(t) :: x
if (x%name/="doodoo") call abort()
if (w/=32) call abort()
end subroutine
subroutine foo(x,y)
type(t),optional :: x
- type(t) :: y
+ class(t) :: y
if(present(x)) then
print *, 'foo', x%i, y%i
else
INTEGER FUNCTION func_add (me, x)
IMPLICIT NONE
- TYPE(add) :: me
+ CLASS(add) :: me
INTEGER :: x
func_add = me%val + x
END FUNCTION func_add
SUBROUTINE sub_add (res, me, x)
IMPLICIT NONE
INTEGER, INTENT(OUT) :: res
- TYPE(add), INTENT(IN) :: me
+ CLASS(add), INTENT(IN) :: me
INTEGER, INTENT(IN) :: x
res = me%val + x
END SUBROUTINE sub_add
SUBROUTINE swap (me1, me2)
IMPLICIT NONE
- TYPE(trueOrFalse), INTENT(INOUT) :: me1, me2
+ CLASS(trueOrFalse), INTENT(INOUT) :: me1, me2
IF (.NOT. me1%val .OR. me2%val) THEN
CALL abort ()
SUBROUTINE swap (me1, me2)
IMPLICIT NONE
- TYPE(trueOrFalse), INTENT(INOUT) :: me1, me2
+ CLASS(trueOrFalse), INTENT(INOUT) :: me1, me2
IF (.NOT. me1%val .OR. me2%val) THEN
CALL abort ()
SUBROUTINE proc (me)
IMPLICIT NONE
- TYPE(t), INTENT(INOUT) :: me
+ CLASS(t), INTENT(INOUT) :: me
END SUBROUTINE proc
INTEGER FUNCTION func ()
SUBROUTINE passed_intint (me, x, y)
IMPLICIT NONE
- TYPE(t) :: me
+ CLASS(t) :: me
INTEGER :: x, y
WRITE (*,*) "Passed Integer"
END SUBROUTINE passed_intint
SUBROUTINE passed_realreal (x, me, y)
IMPLICIT NONE
REAL :: x, y
- TYPE(t) :: me
+ CLASS(t) :: me
WRITE (*,*) "Passed Real"
END SUBROUTINE passed_realreal
subroutine foo_v_inner(x,a)
real :: x(:)
- type(foo) :: a
+ class(foo) :: a
a%i = int(x(1))
WRITE (*,*) "Vector"
subroutine foo_m_inner(x,a)
real :: x(:,:)
- type(foo) :: a
+ class(foo) :: a
a%i = int(x(1,1))
WRITE (*,*) "Matrix"
SUBROUTINE proc1 (me)
IMPLICIT NONE
- TYPE(t1) :: me
+ CLASS(t1) :: me
END SUBROUTINE proc1
REAL FUNCTION proc2 (x, me)
IMPLICIT NONE
REAL :: x
- TYPE(t1) :: me
+ CLASS(t1) :: me
proc2 = x / 2
END FUNCTION proc2
INTEGER FUNCTION proc3 (me)
IMPLICIT NONE
- TYPE(t2) :: me
+ CLASS(t2) :: me
proc3 = 42
END FUNCTION proc3
SUBROUTINE proc_arg_first (me, x)
IMPLICIT NONE
- TYPE(t) :: me
+ CLASS(t) :: me
REAL :: x
END SUBROUTINE proc_arg_first
INTEGER FUNCTION proc_arg_middle (x, me, y)
IMPLICIT NONE
REAL :: x, y
- TYPE(t) :: me
+ CLASS(t) :: me
END FUNCTION proc_arg_middle
SUBROUTINE proc_arg_last (x, me)
IMPLICIT NONE
- TYPE(t) :: me
+ CLASS(t) :: me
REAL :: x
END SUBROUTINE proc_arg_last
SUBROUTINE proc_stme1 (me, a)
IMPLICIT NONE
- TYPE(supert) :: me
+ CLASS(supert) :: me
INTEGER :: a
END SUBROUTINE proc_stme1
SUBROUTINE proc_tme1 (me, a)
IMPLICIT NONE
- TYPE(t) :: me
+ CLASS(t) :: me
INTEGER :: a
END SUBROUTINE proc_tme1
SUBROUTINE proc_stmeme (me1, me2)
IMPLICIT NONE
- TYPE(supert) :: me1, me2
+ CLASS(supert) :: me1, me2
END SUBROUTINE proc_stmeme
SUBROUTINE proc_tmeme (me1, me2)
IMPLICIT NONE
- TYPE(t) :: me1, me2
+ CLASS(t) :: me1, me2
END SUBROUTINE proc_tmeme
SUBROUTINE proc_stmeint (me, a)
IMPLICIT NONE
- TYPE(supert) :: me
+ CLASS(supert) :: me
INTEGER :: a
END SUBROUTINE proc_stmeint
SUBROUTINE proc_tmeint (me, a)
IMPLICIT NONE
- TYPE(t) :: me
+ CLASS(t) :: me
INTEGER :: a
END SUBROUTINE proc_tmeint
SUBROUTINE proc_tmeintx (me, x)
IMPLICIT NONE
- TYPE(t) :: me
+ CLASS(t) :: me
INTEGER :: x
END SUBROUTINE proc_tmeintx
SUBROUTINE proc_tmereal (me, a)
IMPLICIT NONE
- TYPE(t) :: me
+ CLASS(t) :: me
REAL :: a
END SUBROUTINE proc_tmereal
projects / thirdparty / gcc.git / commitdiff
