mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-01-13 07:24:27 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/40940 ([F03] CLASS statement)

Browse Source 
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-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.

From-SVN: r150620
This commit is contained in:
Janus Weil 2009-08-10 11:19:24 +02:00
parent 477eca006c
commit 727e85447d
20 changed files with 210 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View File

@ -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

11
gcc/fortran/decl.c
View File

@ -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;

1
gcc/fortran/gfortran.h
View File

@ -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;

1
gcc/fortran/misc.c
View File

@ -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 */

56
gcc/fortran/resolve.c
View File

@ -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. */

18
gcc/testsuite/ChangeLog
View File

@ -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

40
gcc/testsuite/gfortran.dg/class_1.f03 Normal file
View File

@ -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

47
gcc/testsuite/gfortran.dg/class_2.f03 Normal file
View File

@ -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

4
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90
View File

@ -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

4
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90
View File

@ -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

4
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90
View File

@ -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

2
gcc/testsuite/gfortran.dg/typebound_call_10.f03
View File

@ -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

6
gcc/testsuite/gfortran.dg/typebound_call_2.f03
View File

@ -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 ()

2
gcc/testsuite/gfortran.dg/typebound_call_3.f03
View File

@ -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 ()

2
gcc/testsuite/gfortran.dg/typebound_call_4.f03
View File

@ -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 ()

4
gcc/testsuite/gfortran.dg/typebound_generic_3.f03
View File

@ -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

4
gcc/testsuite/gfortran.dg/typebound_generic_4.f03
View File

@ -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"

6
gcc/testsuite/gfortran.dg/typebound_proc_1.f08
View File

@ -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

6
gcc/testsuite/gfortran.dg/typebound_proc_5.f03
View File

@ -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

16
gcc/testsuite/gfortran.dg/typebound_proc_6.f03
View File

@ -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