re PR fortran/44869 ([OOP] generic TBPs not initialized properly)

2010-07-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44689
	* decl.c (build_sym,attr_decl1): Only build the class container if the
	symbol has sufficient attributes.
	* expr.c (gfc_check_pointer_assign): Use class_pointer instead of
	pointer attribute for classes.
	* match.c (gfc_match_allocate,gfc_match_deallocate): Ditto.
	* module.c (MOD_VERSION): Bump.
	(enum ab_attribute,attr_bits): Add AB_CLASS_POINTER.
	(mio_symbol_attribute): Handle class_pointer attribute.
	* parse.c (parse_derived): Use class_pointer instead of pointer
	attribute for classes.
	* primary.c (gfc_variable_attr,gfc_expr_attr): Ditto.
	* resolve.c (resolve_structure_cons,resolve_deallocate_expr,
	resolve_allocate_expr,resolve_fl_derived): Ditto.
	(resolve_fl_var_and_proc): Check for class_ok attribute.

2010-07-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44689
	* gfortran.dg/class_24.f03: New.

From-SVN: r162052

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6709df3877e12b1ae908ab78aadaccd8305d9606..1c0f727df5927969c636d98d6bf7fa79f4f35938 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+2010-07-11  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/44689
+       * decl.c (build_sym,attr_decl1): Only build the class container if the
+       symbol has sufficient attributes.
+       * expr.c (gfc_check_pointer_assign): Use class_pointer instead of
+       pointer attribute for classes.
+       * match.c (gfc_match_allocate,gfc_match_deallocate): Ditto.
+       * module.c (MOD_VERSION): Bump.
+       (enum ab_attribute,attr_bits): Add AB_CLASS_POINTER.
+       (mio_symbol_attribute): Handle class_pointer attribute.
+       * parse.c (parse_derived): Use class_pointer instead of pointer
+       attribute for classes.
+       * primary.c (gfc_variable_attr,gfc_expr_attr): Ditto.
+       * resolve.c (resolve_structure_cons,resolve_deallocate_expr,
+       resolve_allocate_expr,resolve_fl_derived): Ditto.
+       (resolve_fl_var_and_proc): Check for class_ok attribute.
+
 2010-07-10  Mikael Morin  <mikael@gcc.gnu.org>
 
        * trans-io.c (gfc_build_st_parameter): Update calls to

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index e5ef139d00dc1198e34497b9c8c74716a0dbff9e..9515676acc9b49ceee41f0a83de1b4f3760a4836 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1155,13 +1155,10 @@ build_sym (const char *name, gfc_charlen *cl,
 
   sym->attr.implied_index = 0;
 
-  if (sym->ts.type == BT_CLASS)
-    {
-      sym->attr.class_ok = (sym->attr.dummy
-                             || sym->attr.pointer
-                             || sym->attr.allocatable) ? 1 : 0;
-      gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
-    }
+  if (sym->ts.type == BT_CLASS
+      && (sym->attr.class_ok = sym->attr.dummy || sym->attr.pointer
+                              || sym->attr.allocatable))
+    gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
 
   return SUCCESS;
 }
@@ -5874,7 +5871,7 @@ attr_decl1 (void)
   /* Update symbol table.  DIMENSION attribute is set in
      gfc_set_array_spec().  For CLASS variables, this must be applied
      to the first component, or '$data' field.  */
-  if (sym->ts.type == BT_CLASS)
+  if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
     {
       if (gfc_copy_attr (&CLASS_DATA (sym)->attr, &current_attr,&var_locus)
          == FAILURE)
@@ -5882,8 +5879,6 @@ attr_decl1 (void)
          m = MATCH_ERROR;
          goto cleanup;
        }
-      sym->attr.class_ok = (sym->attr.class_ok || current_attr.allocatable
-                           || current_attr.pointer);
     }
   else
     {
@@ -5894,6 +5889,11 @@ attr_decl1 (void)
          goto cleanup;
        }
     }
+    
+  if (sym->ts.type == BT_CLASS && !sym->attr.class_ok
+      && (sym->attr.class_ok = sym->attr.class_ok || current_attr.allocatable
+                              || current_attr.pointer))
+    gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
 
   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
     {

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index acbec8dcabca3ce9717ac5010a2b5670196b2e7d..39fc7493264ca097b082fe74a660085bbf491aa9 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3306,7 +3306,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
     }
 
   if (!pointer && !proc_pointer
-       && !(lvalue->ts.type == BT_CLASS && CLASS_DATA (lvalue)->attr.pointer))
+      && !(lvalue->ts.type == BT_CLASS
+          && CLASS_DATA (lvalue)->attr.class_pointer))
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
@@ -3543,7 +3544,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
   lvalue.where = sym->declared_at;
 
   if (sym->attr.pointer || sym->attr.proc_pointer
-      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.pointer
+      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
          && rvalue->expr_type == EXPR_NULL))
     r = gfc_check_pointer_assign (&lvalue, rvalue);
   else

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index a51d24c65686df91eb5a26a01f6433c7d5837489..56e9d1d515dd9085be3d98d5579a0ddc1e40623f 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2896,7 +2896,7 @@ gfc_match_allocate (void)
                || tail->expr->ref->type == REF_ARRAY));
       if (sym && sym->ts.type == BT_CLASS)
        b2 = !(CLASS_DATA (sym)->attr.allocatable
-              || CLASS_DATA (sym)->attr.pointer);
+              || CLASS_DATA (sym)->attr.class_pointer);
       else
        b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
                      || sym->attr.proc_pointer);
@@ -3202,7 +3202,7 @@ gfc_match_deallocate (void)
               || tail->expr->ref->type == REF_ARRAY));
       if (sym && sym->ts.type == BT_CLASS)
        b2 = !(CLASS_DATA (sym)->attr.allocatable
-              || CLASS_DATA (sym)->attr.pointer);
+              || CLASS_DATA (sym)->attr.class_pointer);
       else
        b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
                      || sym->attr.proc_pointer);

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index b42a9e8c1d11aff4885ec7be43ab46e661ad7c78..aa6e72eeeff135be77e3b003072b124227dd1c6e 100644 (file)
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -80,7 +80,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Don't put any single quote (') in MOD_VERSION, 
    if yout want it to be recognized.  */
-#define MOD_VERSION "5"
+#define MOD_VERSION "6"
 
 
 /* Structure that describes a position within a module file.  */
@@ -1675,7 +1675,7 @@ typedef enum
   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
-  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS
+  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER
 }
 ab_attribute;
 
@@ -1724,6 +1724,7 @@ static const mstring attr_bits[] =
     minit ("PROC_POINTER", AB_PROC_POINTER),
     minit ("VTYPE", AB_VTYPE),
     minit ("VTAB", AB_VTAB),
+    minit ("CLASS_POINTER", AB_CLASS_POINTER),
     minit (NULL, -1)
 };
 
@@ -1818,6 +1819,8 @@ mio_symbol_attribute (symbol_attribute *attr)
        MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
       if (attr->pointer)
        MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
+      if (attr->class_pointer)
+       MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
       if (attr->is_protected)
        MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
       if (attr->value)
@@ -1933,6 +1936,9 @@ mio_symbol_attribute (symbol_attribute *attr)
            case AB_POINTER:
              attr->pointer = 1;
              break;
+           case AB_CLASS_POINTER:
+             attr->class_pointer = 1;
+             break;
            case AB_PROTECTED:
              attr->is_protected = 1;
              break;

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 50f795723ebcfb8ec41ecc6266d13a1be75a2869..a1af026465893e596882196fe73c80366471850a 100644 (file)
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2103,7 +2103,7 @@ endType:
 
       /* Look for pointer components.  */
       if (c->attr.pointer
-         || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer)
+         || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer)
          || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
        sym->attr.pointer_comp = 1;
 

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index b6c08a9c406f79a168d32179c926384997cbdda7..cb6fae20c41bfd90bc67d215dd4ffd9467e7d255 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1999,7 +1999,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   if (sym->ts.type == BT_CLASS)
     {
       dimension = CLASS_DATA (sym)->attr.dimension;
-      pointer = CLASS_DATA (sym)->attr.pointer;
+      pointer = CLASS_DATA (sym)->attr.class_pointer;
       allocatable = CLASS_DATA (sym)->attr.allocatable;
     }
   else
@@ -2059,7 +2059,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 
        if (comp->ts.type == BT_CLASS)
          {
-           pointer = CLASS_DATA (comp)->attr.pointer;
+           pointer = CLASS_DATA (comp)->attr.class_pointer;
            allocatable = CLASS_DATA (comp)->attr.allocatable;
          }
        else
@@ -2109,7 +2109,7 @@ gfc_expr_attr (gfc_expr *e)
          if (sym->ts.type == BT_CLASS)
            {
              attr.dimension = CLASS_DATA (sym)->attr.dimension;
-             attr.pointer = CLASS_DATA (sym)->attr.pointer;
+             attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
              attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
            }
        }

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 98d1e079e50c408c05bcf74c7c8aa3e5fdad8d18..d5c422ac35ec48bc4d20d29f44ba0e25e68bcf78 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -905,7 +905,7 @@ resolve_structure_cons (gfc_expr *expr)
          && !(comp->attr.pointer || comp->attr.allocatable
               || comp->attr.proc_pointer
               || (comp->ts.type == BT_CLASS
-                  && (CLASS_DATA (comp)->attr.pointer
+                  && (CLASS_DATA (comp)->attr.class_pointer
                       || CLASS_DATA (comp)->attr.allocatable))))
        {
          t = FAILURE;
@@ -6096,7 +6096,7 @@ resolve_deallocate_expr (gfc_expr *e)
   if (sym->ts.type == BT_CLASS)
     {
       allocatable = CLASS_DATA (sym)->attr.allocatable;
-      pointer = CLASS_DATA (sym)->attr.pointer;
+      pointer = CLASS_DATA (sym)->attr.class_pointer;
     }
   else
     {
@@ -6120,7 +6120,7 @@ resolve_deallocate_expr (gfc_expr *e)
          if (c->ts.type == BT_CLASS)
            {
              allocatable = CLASS_DATA (c)->attr.allocatable;
-             pointer = CLASS_DATA (c)->attr.pointer;
+             pointer = CLASS_DATA (c)->attr.class_pointer;
            }
          else
            {
@@ -6319,7 +6319,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       if (sym->ts.type == BT_CLASS)
        {
          allocatable = CLASS_DATA (sym)->attr.allocatable;
-         pointer = CLASS_DATA (sym)->attr.pointer;
+         pointer = CLASS_DATA (sym)->attr.class_pointer;
          dimension = CLASS_DATA (sym)->attr.dimension;
          codimension = CLASS_DATA (sym)->attr.codimension;
          is_abstract = CLASS_DATA (sym)->attr.abstract;
@@ -6357,7 +6357,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
                if (c->ts.type == BT_CLASS)
                  {
                    allocatable = CLASS_DATA (c)->attr.allocatable;
-                   pointer = CLASS_DATA (c)->attr.pointer;
+                   pointer = CLASS_DATA (c)->attr.class_pointer;
                    dimension = CLASS_DATA (c)->attr.dimension;
                    codimension = CLASS_DATA (c)->attr.codimension;
                    is_abstract = CLASS_DATA (c)->attr.abstract;
@@ -9327,7 +9327,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
   if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
     {
       /* F03:C502.  */
-      if (!gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
+      if (sym->attr.class_ok
+         && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived))
        {
          gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
                     CLASS_DATA (sym)->ts.u.derived->name, sym->name,
@@ -11093,7 +11094,7 @@ resolve_fl_derived (gfc_symbol *sym)
          return FAILURE;
        }
 
-      if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer
+      if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer
          && CLASS_DATA (c)->ts.u.derived->components == NULL
          && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp)
        {
@@ -11105,7 +11106,8 @@ resolve_fl_derived (gfc_symbol *sym)
 
       /* C437.  */
       if (c->ts.type == BT_CLASS
-         && !(CLASS_DATA (c)->attr.pointer || CLASS_DATA (c)->attr.allocatable))
+         && !(CLASS_DATA (c)->attr.class_pointer
+              || CLASS_DATA (c)->attr.allocatable))
        {
          gfc_error ("Component '%s' with CLASS at %L must be allocatable "
                     "or pointer", c->name, &c->loc);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3579537c3795db82e79c2df86ebb422068983c94..646aae638799930c735d5b826053cfe343a579ec 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-07-11  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/44689
+       * gfortran.dg/class_24.f03: New.
+
 2010-07-10  Richard Guenther  <rguenther@suse.de>
 
        PR lto/44889

diff --git a/gcc/testsuite/gfortran.dg/class_24.f03 b/gcc/testsuite/gfortran.dg/class_24.f03
new file mode 100644 (file)
index 0000000..085e6d1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_24.f03
@@ -0,0 +1,22 @@
+! { dg-do compile }
+!
+! PR 44869: [OOP] Missing TARGET check - and wrong code or accepts-invalid?
+!
+! Contributed by Satish.BD <bdsatish@gmail.com>
+
+  type :: test_case
+  end type 
+
+  type :: test_suite
+    type(test_case) :: list
+  end type
+
+contains
+
+  subroutine sub(self)
+    class(test_suite), intent(inout) :: self
+    type(test_case), pointer :: tst_case
+    tst_case => self%list       ! { dg-error "is neither TARGET nor POINTER" }
+  end subroutine
+
+end