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

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

gcc/fortran/ChangeLog

+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

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;
 

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; 

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

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

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/class_1.f03

+! { 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
+

gcc/testsuite/gfortran.dg/class_2.f03

+! { 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
+

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

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

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

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

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

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

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

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
 

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"

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
 

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
 

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