OSDN Git Service

2009-08-31 Janus Weil <janus@gcc.gnu.org>
authorjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 31 Aug 2009 19:08:03 +0000 (19:08 +0000)
committerjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 31 Aug 2009 19:08:03 +0000 (19:08 +0000)
    Paul Thomas  <pault@gcc.gnu.org>

PR fortran/40940
* array.c (gfc_match_array_constructor): Rename gfc_match_type_spec.
* decl.c (gfc_match_type_spec): Rename to gfc_match_decl_type_spec,
and reject CLASS with -std=f95.
(gfc_match_implicit, gfc_match_data_decl,gfc_match_prefix,
match_procedure_interface): Rename gfc_match_type_spec.
* gfortran.h (gfc_type_compatible): Add prototype.
* match.h (gfc_match_type_spec): Rename to gfc_match_decl_type_spec.
* match.c (match_intrinsic_typespec): Rename to match_type_spec, and
add handling of derived types.
(gfc_match_allocate): Rename match_intrinsic_typespec and check
type compatibility of derived types.
* symbol.c (gfc_type_compatible): New function to check if two types
are compatible.

2009-08-31  Janus Weil  <janus@gcc.gnu.org>

PR fortran/40940
* gfortran.dg/allocate_derived_1.f90: New.
* gfortran.dg/class_3.f03: New.

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

gcc/fortran/ChangeLog
gcc/fortran/array.c
gcc/fortran/decl.c
gcc/fortran/gfortran.h
gcc/fortran/match.c
gcc/fortran/match.h
gcc/fortran/symbol.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/allocate_derived_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/class_3.f03 [new file with mode: 0644]

index 3d2aad6..e5a673a 100644 (file)
@@ -1,4 +1,22 @@
 2009-08-31  Janus Weil  <janus@gcc.gnu.org>
+           Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/40940
+       * array.c (gfc_match_array_constructor): Rename gfc_match_type_spec.
+       * decl.c (gfc_match_type_spec): Rename to gfc_match_decl_type_spec,
+       and reject CLASS with -std=f95.
+       (gfc_match_implicit, gfc_match_data_decl,gfc_match_prefix,
+       match_procedure_interface): Rename gfc_match_type_spec.
+       * gfortran.h (gfc_type_compatible): Add prototype.
+       * match.h (gfc_match_type_spec): Rename to gfc_match_decl_type_spec.
+       * match.c (match_intrinsic_typespec): Rename to match_type_spec, and
+       add handling of derived types.
+       (gfc_match_allocate): Rename match_intrinsic_typespec and check
+       type compatibility of derived types.
+       * symbol.c (gfc_type_compatible): New function to check if two types
+       are compatible.
+
+2009-08-31  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/40996
        * check.c (gfc_check_allocated): Implement allocatable scalars.
index 3ceb0e7..e1a5f25 100644 (file)
@@ -907,7 +907,7 @@ gfc_match_array_constructor (gfc_expr **result)
   seen_ts = false;
 
   /* Try to match an optional "type-spec ::"  */
-  if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
+  if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
     {
       seen_ts = (gfc_match (" ::") == MATCH_YES);
 
index 40622e2..52796a6 100644 (file)
@@ -2267,8 +2267,8 @@ done:
 }
 
 
-/* Matches a type specification.  If successful, sets the ts structure
-   to the matched specification.  This is necessary for FUNCTION and
+/* Matches a declaration-type-spec (F03:R502).  If successful, sets the ts
+   structure to the matched specification.  This is necessary for FUNCTION and
    IMPLICIT statements.
 
    If implicit_flag is nonzero, then we don't check for the optional
@@ -2276,7 +2276,7 @@ done:
    statement correctly.  */
 
 match
-gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
+gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symbol *sym;
@@ -2377,6 +2377,10 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
        return m;
       ts->is_class = 1;
 
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
+                         == FAILURE)
+       return MATCH_ERROR;
+
       /* TODO: Implement Polymorphism.  */
       gfc_warning ("Polymorphic entities are not yet implemented. "
                   "CLASS will be treated like TYPE at %C");
@@ -2599,7 +2603,7 @@ gfc_match_implicit (void)
       gfc_clear_new_implicit ();
 
       /* A basic type is mandatory here.  */
-      m = gfc_match_type_spec (&ts, 1);
+      m = gfc_match_decl_type_spec (&ts, 1);
       if (m == MATCH_ERROR)
        goto error;
       if (m == MATCH_NO)
@@ -3675,7 +3679,7 @@ gfc_match_data_decl (void)
 
   num_idents_on_line = 0;
   
-  m = gfc_match_type_spec (&current_ts, 0);
+  m = gfc_match_decl_type_spec (&current_ts, 0);
   if (m != MATCH_YES)
     return m;
 
@@ -3780,7 +3784,7 @@ gfc_match_prefix (gfc_typespec *ts)
 
 loop:
   if (!seen_type && ts != NULL
-      && gfc_match_type_spec (ts, 0) == MATCH_YES
+      && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
       && gfc_match_space () == MATCH_YES)
     {
 
@@ -4178,7 +4182,7 @@ match_procedure_interface (gfc_symbol **proc_if)
 
   /* Get the type spec. for the procedure interface.  */
   old_loc = gfc_current_locus;
-  m = gfc_match_type_spec (&current_ts, 0);
+  m = gfc_match_decl_type_spec (&current_ts, 0);
   gfc_gobble_whitespace ();
   if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
     goto got_ts;
index 514cc80..b6ac254 100644 (file)
@@ -2469,6 +2469,7 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
 gfc_typebound_proc* gfc_get_typebound_proc (void);
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
+bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
                                      const char*, bool, locus*);
 gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
index 9ba3e09..ccd1071 100644 (file)
@@ -2221,21 +2221,22 @@ gfc_free_alloc_list (gfc_alloc *p)
 }
 
 
-/* Match a Fortran 2003 intrinsic-type-spec.  This is a stripped
-   down version of gfc_match_type_spec() from decl.c.  It only includes
-   the intrinsic types from the Fortran 2003 standard.  Thus, neither
-   BYTE nor forms like REAL*4 are allowed.  Additionally, the implicit_flag
-   is not needed, so it was removed.  The handling of derived types has
-   been removed and no notion of the gfc_matching_function state
-   is needed.  In short, this functions matches only standard conforming
-   intrinsic-type-spec (R403).  */
+/* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
+   gfc_match_decl_type_spec() from decl.c, with the following exceptions:
+   It only includes the intrinsic types from the Fortran 2003 standard
+   (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
+   the implicit_flag is not needed, so it was removed.  Derived types are
+   identified by their name alone.  */
 
 static match
-match_intrinsic_typespec (gfc_typespec *ts)
+match_type_spec (gfc_typespec *ts)
 {
   match m;
+  gfc_symbol *derived;
+  locus old_locus;
 
   gfc_clear_ts (ts);
+  old_locus = gfc_current_locus;
 
   if (gfc_match ("integer") == MATCH_YES)
     {
@@ -2278,7 +2279,43 @@ match_intrinsic_typespec (gfc_typespec *ts)
       goto kind_selector;
     }
 
-  /* If an intrinsic type is not matched, simply return MATCH_NO.  */ 
+  if (gfc_match_symbol (&derived, 1) == MATCH_YES)
+    {
+      if (derived->attr.flavor == FL_DERIVED)
+       {
+         old_locus = gfc_current_locus;
+         if (gfc_match (" :: ") != MATCH_YES)
+           return MATCH_ERROR;
+         gfc_current_locus = old_locus;
+         ts->type = BT_DERIVED;
+         ts->u.derived = derived;
+         /* Enfore F03:C401.  */
+         if (derived->attr.abstract)
+           {
+             gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
+                        derived->name, &old_locus);
+             return MATCH_ERROR;
+           }
+         return MATCH_YES;
+       }
+      else
+       {
+         if (gfc_match (" :: ") == MATCH_YES)
+           {
+             /* Enforce F03:C476.  */
+             gfc_error ("'%s' at %L is not an accessible derived type",
+                        derived->name, &old_locus);
+             return MATCH_ERROR;
+           }
+         else
+           {
+             gfc_current_locus = old_locus;
+             return MATCH_NO;
+           }
+       }
+    }
+
+  /* If a type is not matched, simply return MATCH_NO.  */ 
   return MATCH_NO;
 
 kind_selector:
@@ -2379,9 +2416,9 @@ gfc_match_allocate (void)
   if (gfc_match_char ('(') != MATCH_YES)
     goto syntax;
 
-  /* Match an optional intrinsic-type-spec.  */
+  /* Match an optional type-spec.  */
   old_locus = gfc_current_locus;
-  m = match_intrinsic_typespec (&ts);
+  m = match_type_spec (&ts);
   if (m == MATCH_ERROR)
     goto cleanup;
   else if (m == MATCH_NO)
@@ -2430,15 +2467,15 @@ gfc_match_allocate (void)
         constraints.  */
       if (ts.type != BT_UNKNOWN)
        {
-         /* Enforce C626.  */
-         if (ts.type != tail->expr->ts.type)
+         /* Enforce F03:C624.  */
+         if (!gfc_type_compatible (&tail->expr->ts, &ts))
            {
              gfc_error ("Type of entity at %L is type incompatible with "
                         "typespec", &tail->expr->where);
              goto cleanup;
            }
 
-         /* Enforce C627.  */
+         /* Enforce F03:C627.  */
          if (ts.kind != tail->expr->ts.kind)
            {
              gfc_error ("Kind type parameter for entity at %L differs from "
index b6c0924..196115c 100644 (file)
@@ -138,7 +138,7 @@ match gfc_match_data (void);
 match gfc_match_null (gfc_expr **);
 match gfc_match_kind_spec (gfc_typespec *, bool);
 match gfc_match_old_kind_spec (gfc_typespec *);
-match gfc_match_type_spec (gfc_typespec *, int);
+match gfc_match_decl_type_spec (gfc_typespec *, int);
 
 match gfc_match_end (gfc_statement *);
 match gfc_match_data_decl (void);
index 150d149..f6ce3cf 100644 (file)
@@ -4534,6 +4534,32 @@ gfc_get_derived_super_type (gfc_symbol* derived)
 }
 
 
+/* Check if two typespecs are type compatible (F03:5.1.1.2):
+   If ts1 is nonpolymorphic, ts2 must be the same type.
+   If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
+
+bool
+gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+  if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED)
+    {
+      gfc_symbol *t0, *t;
+      if (ts1->is_class)
+       {
+         t0 = ts1->u.derived;
+         t = ts2->u.derived;
+         while (t0 != t && t->attr.extension)
+           t = gfc_get_derived_super_type (t);
+         return (t0 == t);
+       }
+      else
+       return (ts1->u.derived == ts2->u.derived);
+    }
+  else
+    return (ts1->type == ts2->type);
+}
+
+
 /* General worker function to find either a type-bound procedure or a
    type-bound user operator.  */
 
index 6641a43..eba8f6e 100644 (file)
@@ -1,5 +1,11 @@
 2009-08-31  Janus Weil  <janus@gcc.gnu.org>
 
+       PR fortran/40940
+       * gfortran.dg/allocate_derived_1.f90: New.
+       * gfortran.dg/class_3.f03: New.
+
+2009-08-31  Janus Weil  <janus@gcc.gnu.org>
+
        PR fortran/40996
        * gfortran.dg/allocatable_scalar_1.f90: New.
        * gfortran.dg/allocatable_scalar_2.f90: Renamed from finalize_9.f03.
diff --git a/gcc/testsuite/gfortran.dg/allocate_derived_1.f90 b/gcc/testsuite/gfortran.dg/allocate_derived_1.f90
new file mode 100644 (file)
index 0000000..d74851e
--- /dev/null
@@ -0,0 +1,53 @@
+! { dg-do compile }
+!
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+!
+! ALLOCATE statements with derived type specification
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ type :: t1
+  integer :: i
+ end type
+
+ type, extends(t1) :: t2
+  real :: r
+ end type
+
+ type, extends(t2) :: t3
+  real :: q
+ end type
+
+ type, abstract :: u0
+  logical :: nothing
+ end type
+
+ type :: v1
+  real :: r
+ end type
+
+ class(t1),dimension(:),allocatable :: x
+ type(t2),dimension(:),allocatable :: y
+ class(t3),dimension(:),allocatable :: z
+
+ allocate(      x(1))
+ allocate(t1 :: x(2))
+ allocate(t2 :: x(3))
+ allocate(t3 :: x(4))
+ allocate(tx :: x(5))  ! { dg-error "is not an accessible derived type" }
+ allocate(u0 :: x(6))  ! { dg-error "may not be ABSTRACT" }
+ allocate(v1 :: x(7))  ! { dg-error "is type incompatible with typespec" }
+
+ allocate(      y(1))
+ allocate(t1 :: y(2))  ! { dg-error "is type incompatible with typespec" }
+ allocate(t2 :: y(3))
+ allocate(t3 :: y(3))  ! { dg-error "is type incompatible with typespec" }
+
+ allocate(      z(1))
+ allocate(t1 :: z(2))  ! { dg-error "is type incompatible with typespec" }
+ allocate(t2 :: z(3))  ! { dg-error "is type incompatible with typespec" }
+ allocate(t3 :: z(4))
+
+end
+
diff --git a/gcc/testsuite/gfortran.dg/class_3.f03 b/gcc/testsuite/gfortran.dg/class_3.f03
new file mode 100644 (file)
index 0000000..8e15f0e
--- /dev/null
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR 40940: [F03] CLASS statement
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ type :: t
+  integer :: comp
+ end type
+
+ class(t), pointer :: cl  ! { dg-error "CLASS statement" }
+
+end
+