OSDN Git Service

2009-10-17 Janus Weil <janus@gcc.gnu.org>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 17 Oct 2009 18:09:25 +0000 (18:09 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 17 Oct 2009 18:09:25 +0000 (18:09 +0000)
    Paul Thomas  <pault@gcc.gnu.org>

PR fortran/41608
* decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
and empty type errors.
* parse.c (gfc_build_block_ns): Only set recursive if parent ns
has a proc_name.

PR fortran/41629
PR fortran/41618
PR fortran/41587
* gfortran.h : Add class_ok bitfield to symbol_attr.
* decl.c (build_sym): Set attr.class_ok if dummy, pointer or
allocatable.
(build_struct): Use gfc_try 't' to carry errors past the call
to encapsulate_class_symbol.
(attr_decl1): For a CLASS object, apply the new attribute to
the data component.
* match.c (gfc_match_select_type): Set attr.class_ok for an
assigned selector.
* resolve.c (resolve_fl_variable_derived): Check a CLASS object
is dummy, pointer or allocatable by testing the class_ok and
the use_assoc attribute.

2009-10-17  Janus Weil  <janus@gcc.gnu.org>
    Paul Thomas  <pault@gcc.gnu.org>

PR fortran/41629
* gfortran.dg/class_6.f90: New test.

PR fortran/41608
PR fortran/41587
* gfortran.dg/class_7.f90: New test.

PR fortran/41618
* gfortran.dg/class_8.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152955 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/decl.c
gcc/fortran/gfortran.h
gcc/fortran/match.c
gcc/fortran/parse.c
gcc/fortran/resolve.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/class_6.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/class_7.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/class_8.f03 [new file with mode: 0644]

index 17bbc06..24e83e6 100644 (file)
@@ -1,3 +1,28 @@
+2009-10-17  Janus Weil  <janus@gcc.gnu.org>
+           Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/41608
+       * decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
+       and empty type errors.
+       * parse.c (gfc_build_block_ns): Only set recursive if parent ns
+       has a proc_name.
+
+       PR fortran/41629
+       PR fortran/41618
+       PR fortran/41587
+       * gfortran.h : Add class_ok bitfield to symbol_attr.
+       * decl.c (build_sym): Set attr.class_ok if dummy, pointer or
+       allocatable.
+       (build_struct): Use gfc_try 't' to carry errors past the call
+       to encapsulate_class_symbol.
+       (attr_decl1): For a CLASS object, apply the new attribute to
+       the data component.
+       * match.c (gfc_match_select_type): Set attr.class_ok for an
+       assigned selector.
+       * resolve.c (resolve_fl_variable_derived): Check a CLASS object
+       is dummy, pointer or allocatable by testing the class_ok and
+       the use_assoc attribute.
+
 2009-10-16  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/41719
index 2627e60..08d2bd6 100644 (file)
@@ -1181,7 +1181,12 @@ build_sym (const char *name, gfc_charlen *cl,
   sym->attr.implied_index = 0;
 
   if (sym->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+    {
+      sym->attr.class_ok = (sym->attr.dummy
+                             || sym->attr.pointer
+                             || sym->attr.allocatable) ? 1 : 0;
+      encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+    }
 
   return SUCCESS;
 }
@@ -1472,6 +1477,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
              gfc_array_spec **as)
 {
   gfc_component *c;
+  gfc_try t = SUCCESS;
 
   /* F03:C438/C439. If the current symbol is of the same derived type that we're
      constructing, it must have the pointer attribute.  */
@@ -1554,12 +1560,9 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
        }
     }
 
-  if (c->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
-
   /* Check array components.  */
   if (!c->attr.dimension)
-    return SUCCESS;
+    goto scalar;
 
   if (c->attr.pointer)
     {
@@ -1567,7 +1570,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
        {
          gfc_error ("Pointer array component of structure at %C must have a "
                     "deferred shape");
-         return FAILURE;
+         t = FAILURE;
        }
     }
   else if (c->attr.allocatable)
@@ -1576,7 +1579,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
        {
          gfc_error ("Allocatable component of structure at %C must have a "
                     "deferred shape");
-         return FAILURE;
+         t = FAILURE;
        }
     }
   else
@@ -1585,11 +1588,15 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
        {
          gfc_error ("Array component of structure at %C must have an "
                     "explicit shape");
-         return FAILURE;
+         t = FAILURE;
        }
     }
 
-  return SUCCESS;
+scalar:
+  if (c->ts.type == BT_CLASS)
+    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+
+  return t;
 }
 
 
@@ -3761,7 +3768,8 @@ gfc_match_data_decl (void)
   if (m != MATCH_YES)
     return m;
 
-  if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
+  if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+       && gfc_current_state () != COMP_DERIVED)
     {
       sym = gfc_use_derived (current_ts.u.derived);
 
@@ -3781,7 +3789,8 @@ gfc_match_data_decl (void)
       goto cleanup;
     }
 
-  if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
+  if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+      && current_ts.u.derived->components == NULL
       && !current_ts.u.derived->attr.zero_comp)
     {
 
@@ -5694,13 +5703,31 @@ attr_decl1 (void)
        }
     }
 
-  /* Update symbol table.  DIMENSION attribute is set
-     in gfc_set_array_spec().  */
-  if (current_attr.dimension == 0
-      && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+  /* 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 && sym->ts.u.derived)
     {
-      m = MATCH_ERROR;
-      goto cleanup;
+      gfc_component *comp;
+      comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
+      if (comp == NULL || gfc_copy_attr (&comp->attr, &current_attr,
+                                        &var_locus) == FAILURE)
+       {
+         m = MATCH_ERROR;
+         goto cleanup;
+       }
+      sym->attr.class_ok = (sym->attr.class_ok
+                             || current_attr.allocatable
+                             || current_attr.pointer);
+    }
+  else
+    {
+      if (current_attr.dimension == 0
+           && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+       {
+         m = MATCH_ERROR;
+         goto cleanup;
+       }
     }
 
   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
index f6b172a..74a31d2 100644 (file)
@@ -672,6 +672,7 @@ typedef struct
   unsigned is_bind_c:1;                /* say if is bound to C.  */
   unsigned extension:1;                /* extends a derived type.  */
   unsigned is_class:1;         /* is a CLASS container.  */
+  unsigned class_ok:1;         /* is a CLASS object with correct attributes.  */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
index 3542944..d75ef0e 100644 (file)
@@ -4080,6 +4080,7 @@ gfc_match_select_type (void)
        return MATCH_ERROR;
       expr1->symtree->n.sym->ts = expr2->ts;
       expr1->symtree->n.sym->attr.referenced = 1;
+      expr1->symtree->n.sym->attr.class_ok = 1;
     }
   else
     {
index 49d449c..c168c52 100644 (file)
@@ -3069,7 +3069,9 @@ gfc_build_block_ns (gfc_namespace *parent_ns)
                          my_ns->proc_name->name, NULL);
       gcc_assert (t == SUCCESS);
     }
-  my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+  if (parent_ns->proc_name)
+    my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
 
   return my_ns;
 }
index d76c461..285228c 100644 (file)
@@ -8641,9 +8641,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
        }
 
       /* C509.  */
-      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
-             || sym->ts.u.derived->components->attr.allocatable
-             || sym->ts.u.derived->components->attr.pointer))
+      /* Assume that use associated symbols were checked in the module ns.  */ 
+      if (!sym->attr.class_ok && !sym->attr.use_assoc)
        {
          gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
                     "or pointer", sym->name, &sym->declared_at);
index 223d170..1490061 100644 (file)
@@ -1,3 +1,16 @@
+2009-10-17  Janus Weil  <janus@gcc.gnu.org>
+           Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/41629
+       * gfortran.dg/class_6.f90: New test.
+
+       PR fortran/41608
+       PR fortran/41587
+       * gfortran.dg/class_7.f90: New test.
+
+       PR fortran/41618
+       * gfortran.dg/class_8.f90: New test.
+
 2009-10-17  Richard Guenther  <rguenther@suse.de>
 
        * gcc.dg/lto/20091017-1_0.c: New testcase.
diff --git a/gcc/testsuite/gfortran.dg/class_6.f03 b/gcc/testsuite/gfortran.dg/class_6.f03
new file mode 100644 (file)
index 0000000..2f3ff62
--- /dev/null
@@ -0,0 +1,21 @@
+! { dg-do run }
+!
+! PR 41629: [OOP] gimplification error on valid code
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  type t1
+    integer :: comp
+  end type
+
+  type(t1), target :: a
+
+  class(t1) :: x
+  pointer :: x       ! This is valid
+
+  a%comp = 3
+  x => a
+  print *,x%comp
+  if (x%comp/=3) call abort()
+
+end
diff --git a/gcc/testsuite/gfortran.dg/class_7.f03 b/gcc/testsuite/gfortran.dg/class_7.f03
new file mode 100644 (file)
index 0000000..ed4eeba
--- /dev/null
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! Test fixes for PR41587 and PR41608.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+! PR41587: used to accept the declaration of component 'foo'
+  type t0
+    integer :: j = 42
+  end type t0
+  type t
+    integer :: i
+    class(t0), allocatable :: foo(3)  ! { dg-error "deferred shape" }
+  end type t
+
+! PR41608: Would ICE on missing type decl
+  class(t1), pointer :: c  ! { dg-error "before it is defined" }
+
+  select type (c)          ! { dg-error "shall be polymorphic" }
+    type is (t1)           ! { dg-error "Unexpected" }
+  end select               ! { dg-error "Expecting END PROGRAM" }
+end
diff --git a/gcc/testsuite/gfortran.dg/class_8.f03 b/gcc/testsuite/gfortran.dg/class_8.f03
new file mode 100644 (file)
index 0000000..78f10eb
--- /dev/null
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! Test fixes for PR41618.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+!
+ type t1
+   integer :: comp
+   class(t1),pointer :: cc
+ end type
+
+ class(t1) :: x ! { dg-error "must be dummy, allocatable or pointer" }
+
+ x%comp = 3
+ print *,x%comp
+
+end