2010-06-26 Tobias Burnus <burnus@net-b.de>

        * decl.c (gfc_match_decl_type_spec): Support
        TYPE(intrinsic-type-spec).

2010-06-26  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/type_decl_1.f90: New.
        * gfortran.dg/type_decl_2.f90: New.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c09de21..a9f13a8 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2010-06-26  Tobias Burnus  <burnus@net-b.de>
+
+       * decl.c (gfc_match_decl_type_spec): Support
+       TYPE(intrinsic-type-spec).
+
 2010-06-25  Tobias Burnus  <burnus@net-b.de>
 
        * intrinsic.h (gfc_check_selected_real_kind,

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index c2b1ff2..07c3acb 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2342,7 +2342,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
   gfc_symbol *sym;
   match m;
   char c;
-  bool seen_deferred_kind;
+  bool seen_deferred_kind, matched_type;
 
   /* A belt and braces check that the typespec is correctly being treated
      as a deferred characteristic association.  */
@@ -2374,47 +2374,88 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
       return MATCH_YES;
     }
 
-  if (gfc_match (" integer") == MATCH_YES)
+
+  m = gfc_match (" type ( %n", name);
+  matched_type = (m == MATCH_YES);
+  
+  if ((matched_type && strcmp ("integer", name) == 0)
+      || (!matched_type && gfc_match (" integer") == MATCH_YES))
     {
       ts->type = BT_INTEGER;
       ts->kind = gfc_default_integer_kind;
       goto get_kind;
     }
 
-  if (gfc_match (" character") == MATCH_YES)
+  if ((matched_type && strcmp ("character", name) == 0)
+      || (!matched_type && gfc_match (" character") == MATCH_YES))
     {
+      if (matched_type
+         && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+                         "intrinsic-type-spec at %C") == FAILURE)
+       return MATCH_ERROR;
+
       ts->type = BT_CHARACTER;
       if (implicit_flag == 0)
-       return gfc_match_char_spec (ts);
+       m = gfc_match_char_spec (ts);
       else
-       return MATCH_YES;
+       m = MATCH_YES;
+
+      if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
+       m = MATCH_ERROR;
+
+      return m;
     }
 
-  if (gfc_match (" real") == MATCH_YES)
+  if ((matched_type && strcmp ("real", name) == 0)
+      || (!matched_type && gfc_match (" real") == MATCH_YES))
     {
       ts->type = BT_REAL;
       ts->kind = gfc_default_real_kind;
       goto get_kind;
     }
 
-  if (gfc_match (" double precision") == MATCH_YES)
+  if ((matched_type
+       && (strcmp ("doubleprecision", name) == 0
+          || (strcmp ("double", name) == 0
+              && gfc_match (" precision") == MATCH_YES)))
+      || (!matched_type && gfc_match (" double precision") == MATCH_YES))
     {
+      if (matched_type
+         && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+                         "intrinsic-type-spec at %C") == FAILURE)
+       return MATCH_ERROR;
+      if (matched_type && gfc_match_char (')') != MATCH_YES)
+       return MATCH_ERROR;
+
       ts->type = BT_REAL;
       ts->kind = gfc_default_double_kind;
       return MATCH_YES;
     }
 
-  if (gfc_match (" complex") == MATCH_YES)
+  if ((matched_type && strcmp ("complex", name) == 0)
+      || (!matched_type && gfc_match (" complex") == MATCH_YES))
     {
       ts->type = BT_COMPLEX;
       ts->kind = gfc_default_complex_kind;
       goto get_kind;
     }
 
-  if (gfc_match (" double complex") == MATCH_YES)
+  if ((matched_type
+       && (strcmp ("doublecomplex", name) == 0
+          || (strcmp ("double", name) == 0
+              && gfc_match (" complex") == MATCH_YES)))
+      || (!matched_type && gfc_match (" double complex") == MATCH_YES))
     {
-      if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
-                         "conform to the Fortran 95 standard") == FAILURE)
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
+         == FAILURE)
+       return MATCH_ERROR;
+
+      if (matched_type
+         && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+                         "intrinsic-type-spec at %C") == FAILURE)
+       return MATCH_ERROR;
+
+      if (matched_type && gfc_match_char (')') != MATCH_YES)
        return MATCH_ERROR;
 
       ts->type = BT_COMPLEX;
@@ -2422,14 +2463,17 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
       return MATCH_YES;
     }
 
-  if (gfc_match (" logical") == MATCH_YES)
+  if ((matched_type && strcmp ("logical", name) == 0)
+      || (!matched_type && gfc_match (" logical") == MATCH_YES))
     {
       ts->type = BT_LOGICAL;
       ts->kind = gfc_default_logical_kind;
       goto get_kind;
     }
 
-  m = gfc_match (" type ( %n )", name);
+  if (matched_type)
+    m = gfc_match_char (')');
+
   if (m == MATCH_YES)
     ts->type = BT_DERIVED;
   else
@@ -2490,23 +2534,43 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
   return MATCH_YES;
 
 get_kind:
+  if (matched_type
+      && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+                        "intrinsic-type-spec at %C") == FAILURE)
+    return MATCH_ERROR;
+
   /* For all types except double, derived and character, look for an
      optional kind specifier.  MATCH_NO is actually OK at this point.  */
   if (implicit_flag == 1)
-    return MATCH_YES;
+    {
+       if (matched_type && gfc_match_char (')') != MATCH_YES)
+         return MATCH_ERROR;
+
+       return MATCH_YES;
+    }
 
   if (gfc_current_form == FORM_FREE)
     {
       c = gfc_peek_ascii_char ();
       if (!gfc_is_whitespace (c) && c != '*' && c != '('
          && c != ':' && c != ',')
-       return MATCH_NO;
+        {
+         if (matched_type && c == ')')
+           {
+             gfc_next_ascii_char ();
+             return MATCH_YES;
+           }
+         return MATCH_NO;
+       }
     }
 
   m = gfc_match_kind_spec (ts, false);
   if (m == MATCH_NO && ts->type != BT_CHARACTER)
     m = gfc_match_old_kind_spec (ts);
 
+  if (matched_type && gfc_match_char (')') != MATCH_YES)
+    return MATCH_ERROR;
+
   /* Defer association of the KIND expression of function results
      until after USE and IMPORT statements.  */
   if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3984dd7..084c75e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2010-06-26  Tobias Burnus  <burnus@net-b.de>
 
+       * gfortran.dg/type_decl_1.f90: New.
+       * gfortran.dg/type_decl_2.f90: New.
+
+2010-06-26  Tobias Burnus  <burnus@net-b.de>
+
        * gfortran.dg/semicolon_fixed.f: Fix dg syntax..
        * gfortran.dg/semicolon_fixed_2.f: Ditto.
 

diff --git a/gcc/testsuite/gfortran.dg/type_decl_1.f90 b/gcc/testsuite/gfortran.dg/type_decl_1.f90
new file mode 100644 (file)
index 0000000..9392865
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/type_decl_1.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! Fortran 2008: TYPE ( intrinsic-type-spec )
+!
+implicit none
+type(integer) :: a
+type(real) :: b
+type(logical ) :: c
+type(character) :: d
+type(double precision) :: e
+
+type(integer(8)) :: f
+type(real(kind=4)) :: g
+type(logical ( kind = 1 ) ) :: h
+type(character (len=10,kind=1) ) :: i
+
+type(double complex) :: j ! { dg-error "Extension: DOUBLE COMPLEX" }
+end
+
+module m
+  integer, parameter :: k4  = 4
+end module m
+
+type(integer (kind=k4)) function f()
+  use m
+  f = 42
+end
+
+! { dg-final { cleanup-modules "m" } }

diff --git a/gcc/testsuite/gfortran.dg/type_decl_2.f90 b/gcc/testsuite/gfortran.dg/type_decl_2.f90
new file mode 100644 (file)
index 0000000..6525880
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/type_decl_2.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! Fortran 2008: TYPE ( intrinsic-type-spec )
+!
+implicit none
+type(integer)          :: a ! { dg-error "Fortran 2008" }
+type(real)             :: b ! { dg-error "Fortran 2008" }
+type(logical)          :: c ! { dg-error "Fortran 2008" }
+type(character)        :: d ! { dg-error "Fortran 2008" }
+type(double precision) :: e ! { dg-error "Fortran 2008" }
+end