diff options
Diffstat (limited to 'gcc')
20 files changed, 210 insertions, 40 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a064c8a..6158a72 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +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 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 67ccfda..6b6203e 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2369,7 +2369,16 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag) 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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index cefe3ec..3d95d217 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -841,6 +841,7 @@ typedef struct 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; diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 94d61c9..7e4b481 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -71,6 +71,7 @@ gfc_clear_ts (gfc_typespec *ts) 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 */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 39f3cdc..81c8ccd 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7916,6 +7916,15 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) } +/* 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. */ @@ -7964,6 +7973,25 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) 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)) @@ -9000,9 +9028,12 @@ resolve_typebound_procedure (gfc_symtree* stree) 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 @@ -9164,7 +9195,7 @@ resolve_fl_derived (gfc_symbol *sym) 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); @@ -9340,11 +9371,9 @@ resolve_fl_derived (gfc_symbol *sym) 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); } @@ -9412,6 +9441,15 @@ resolve_fl_derived (gfc_symbol *sym) 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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0d67a05..d1e2b1d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,21 @@ +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 diff --git a/gcc/testsuite/gfortran.dg/class_1.f03 b/gcc/testsuite/gfortran.dg/class_1.f03 new file mode 100644 index 0000000..bdd742b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_1.f03 @@ -0,0 +1,40 @@ +! { 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 + diff --git a/gcc/testsuite/gfortran.dg/class_2.f03 b/gcc/testsuite/gfortran.dg/class_2.f03 new file mode 100644 index 0000000..b402045 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_2.f03 @@ -0,0 +1,47 @@ +! { 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 + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 index 14a21ec..2a73bda 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 @@ -17,7 +17,7 @@ module mymod 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 @@ -25,7 +25,7 @@ module mymod 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 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 index c6671a6..9e3cd58 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 @@ -17,14 +17,14 @@ module passed_object_example 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 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 index 15a0904..3c56794 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 @@ -16,7 +16,7 @@ abstract interface subroutine obp(w,x) import :: t integer :: w - type(t) :: x + class(t) :: x end subroutine end interface @@ -30,7 +30,7 @@ contains 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 diff --git a/gcc/testsuite/gfortran.dg/typebound_call_10.f03 b/gcc/testsuite/gfortran.dg/typebound_call_10.f03 index 29b6401..77667fb 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_10.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_10.f03 @@ -19,7 +19,7 @@ contains 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 diff --git a/gcc/testsuite/gfortran.dg/typebound_call_2.f03 b/gcc/testsuite/gfortran.dg/typebound_call_2.f03 index d3149d5..f6e623c 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_2.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_2.f03 @@ -27,7 +27,7 @@ CONTAINS 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 @@ -35,14 +35,14 @@ CONTAINS 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 () diff --git a/gcc/testsuite/gfortran.dg/typebound_call_3.f03 b/gcc/testsuite/gfortran.dg/typebound_call_3.f03 index f06e1cb..028c5b1 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_3.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_3.f03 @@ -19,7 +19,7 @@ CONTAINS 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 () diff --git a/gcc/testsuite/gfortran.dg/typebound_call_4.f03 b/gcc/testsuite/gfortran.dg/typebound_call_4.f03 index d05838b..25745fd 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_4.f03 @@ -24,7 +24,7 @@ CONTAINS SUBROUTINE proc (me) IMPLICIT NONE - TYPE(t), INTENT(INOUT) :: me + CLASS(t), INTENT(INOUT) :: me END SUBROUTINE proc INTEGER FUNCTION func () diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 index fc56574..d708282 100644 --- a/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 @@ -35,7 +35,7 @@ CONTAINS SUBROUTINE passed_intint (me, x, y) IMPLICIT NONE - TYPE(t) :: me + CLASS(t) :: me INTEGER :: x, y WRITE (*,*) "Passed Integer" END SUBROUTINE passed_intint @@ -43,7 +43,7 @@ CONTAINS SUBROUTINE passed_realreal (x, me, y) IMPLICIT NONE REAL :: x, y - TYPE(t) :: me + CLASS(t) :: me WRITE (*,*) "Passed Real" END SUBROUTINE passed_realreal diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 index edd62be..28af021 100644 --- a/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 @@ -25,7 +25,7 @@ contains subroutine foo_v_inner(x,a) real :: x(:) - type(foo) :: a + class(foo) :: a a%i = int(x(1)) WRITE (*,*) "Vector" @@ -33,7 +33,7 @@ contains subroutine foo_m_inner(x,a) real :: x(:,:) - type(foo) :: a + class(foo) :: a a%i = int(x(1,1)) WRITE (*,*) "Matrix" diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 b/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 index dafd684..3437baa 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 @@ -51,19 +51,19 @@ CONTAINS 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 diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 index edc55a1..1251e3f 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 @@ -71,19 +71,19 @@ CONTAINS 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 diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 index e7d09a0..eba4836 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 @@ -134,47 +134,47 @@ CONTAINS 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 |