re PR fortran/54730 (ICE in gfc_typenode_for_spec, at fortran/trans-types.c:1066)

2016-10-23  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/54730
	PR fortran/78033
	* array.c (gfc_match_array_constructor): Remove checkpointing
	introduced in r196416 (original fix for PR fortran/54730).  Move
	initialization to top of function.
	* match.c (gfc_match_type_spec): Special case matching for REAL.

2016-10-23  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/54730
	PR fortran/78033
	* gfortran.dg/pr78033.f90: New test.

From-SVN: r241451

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d057d0fade08ce0efe28b2a009091bed5ad016ff..0931104b740247f0a1ad707e4f1a83f2f1fbf35c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2016-10-23  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+       PR fortran/54730
+       PR fortran/78033
+       * array.c (gfc_match_array_constructor): Remove checkpointing
+       introduced in r196416 (original fix for PR fortran/54730).  Move
+       initialization to top of function.
+       * match.c (gfc_match_type_spec): Special case matching for REAL.
+
 2016-10-23  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/69834

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 3e0218a01835d07e75b1771161ede7c06bbabbaf..e6917a53850814f55af1d430595f0a1919201d1e 100644 (file)
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1091,7 +1091,6 @@ gfc_match_array_constructor (gfc_expr **result)
 {
   gfc_constructor *c;
   gfc_constructor_base head;
-  gfc_undo_change_set changed_syms;
   gfc_expr *expr;
   gfc_typespec ts;
   locus where;
@@ -1099,6 +1098,9 @@ gfc_match_array_constructor (gfc_expr **result)
   const char *end_delim;
   bool seen_ts;
 
+  head = NULL;
+  seen_ts = false;
+
   if (gfc_match (" (/") == MATCH_NO)
     {
       if (gfc_match (" [") == MATCH_NO)
@@ -1115,12 +1117,9 @@ gfc_match_array_constructor (gfc_expr **result)
     end_delim = " /)";
 
   where = gfc_current_locus;
-  head = NULL;
-  seen_ts = false;
 
   /* Try to match an optional "type-spec ::"  */
   gfc_clear_ts (&ts);
-  gfc_new_undo_checkpoint (changed_syms);
   m = gfc_match_type_spec (&ts);
   if (m == MATCH_YES)
     {
@@ -1130,16 +1129,12 @@ gfc_match_array_constructor (gfc_expr **result)
        {
          if (!gfc_notify_std (GFC_STD_F2003, "Array constructor "
                               "including type specification at %C"))
-           {
-             gfc_restore_last_undo_checkpoint ();
-             goto cleanup;
-           }
+           goto cleanup;
 
          if (ts.deferred)
            {
              gfc_error ("Type-spec at %L cannot contain a deferred "
                         "type parameter", &where);
-             gfc_restore_last_undo_checkpoint ();
              goto cleanup;
            }
 
@@ -1148,24 +1143,15 @@ gfc_match_array_constructor (gfc_expr **result)
            {
              gfc_error ("Type-spec at %L cannot contain an asterisk for a "
                         "type parameter", &where);
-             gfc_restore_last_undo_checkpoint ();
              goto cleanup;
            }
        }
     }
   else if (m == MATCH_ERROR)
-    {
-      gfc_restore_last_undo_checkpoint ();
-      goto cleanup;
-    }
+    goto cleanup;
 
-  if (seen_ts)
-    gfc_drop_last_undo_checkpoint ();
-  else
-    {
-      gfc_restore_last_undo_checkpoint ();
-      gfc_current_locus = where;
-    }
+  if (!seen_ts)
+    gfc_current_locus = where;
 
   if (gfc_match (end_delim) == MATCH_YES)
     {

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index a19968ba7e8a4fe48c58b36c67ab62902987a28c..ae9e1d0ce8301ae4f08ca51a2b9ddb875166e046 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1989,6 +1989,7 @@ gfc_match_type_spec (gfc_typespec *ts)
 {
   match m;
   locus old_locus;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
 
   gfc_clear_ts (ts);
   gfc_gobble_whitespace ();
@@ -2013,13 +2014,6 @@ gfc_match_type_spec (gfc_typespec *ts)
       goto kind_selector;
     }
 
-  if (gfc_match ("real") == MATCH_YES)
-    {
-      ts->type = BT_REAL;
-      ts->kind = gfc_default_real_kind;
-      goto kind_selector;
-    }
-
   if (gfc_match ("double precision") == MATCH_YES)
     {
       ts->type = BT_REAL;
@@ -2053,6 +2047,103 @@ gfc_match_type_spec (gfc_typespec *ts)
       goto kind_selector;
     }
 
+  /* REAL is a real pain because it can be a type, intrinsic subprogram,
+     or list item in a type-list of an OpenMP reduction clause.  Need to
+     differentiate REAL([KIND]=scalar-int-initialization-expr) from
+     REAL(A,[KIND]) and REAL(KIND,A).  */
+
+  m = gfc_match (" %n", name);
+  if (m == MATCH_YES && strcmp (name, "real") == 0)
+    {
+      char c;
+      gfc_expr *e;
+      locus where;
+
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_real_kind;
+
+      gfc_gobble_whitespace ();
+
+      /* Prevent REAL*4, etc.  */
+      c = gfc_peek_ascii_char ();
+      if (c == '*')
+       {
+         gfc_error ("Invalid type-spec at %C");
+         return MATCH_ERROR;
+       }
+
+      /* Found leading colon in REAL::, a trailing ')' in for example
+        TYPE IS (REAL), or REAL, for an OpenMP list-item.  */
+      if (c == ':' || c == ')' || (flag_openmp && c == ','))
+       return MATCH_YES;
+
+      /* Found something other than the opening '(' in REAL(...  */
+      if (c != '(')
+       return MATCH_NO;
+      else
+       gfc_next_char (); /* Burn the '('. */
+
+      /* Look for the optional KIND=. */
+      where = gfc_current_locus;
+      m = gfc_match ("%n", name);
+      if (m == MATCH_YES)
+       {
+         gfc_gobble_whitespace ();
+         c = gfc_next_char ();
+         if (c == '=')
+           {
+             if (strcmp(name, "a") == 0)
+               return MATCH_NO;
+             else if (strcmp(name, "kind") == 0)
+               goto found;
+             else
+               return MATCH_ERROR;
+           }
+         else
+           gfc_current_locus = where;
+       }
+      else
+       gfc_current_locus = where;
+
+found:
+
+      m = gfc_match_init_expr (&e);
+      if (m == MATCH_NO || m == MATCH_ERROR)
+       return MATCH_NO;
+
+      /* If a comma appears, it is an intrinsic subprogram. */
+      gfc_gobble_whitespace ();
+      c = gfc_peek_ascii_char ();
+      if (c == ',')
+       {
+         gfc_free_expr (e);
+         return MATCH_NO;
+       }
+
+      /* If ')' appears, we have REAL(initialization-expr), here check for
+        a scalar integer initialization-expr and valid kind parameter. */
+      if (c == ')')
+       {
+         if (e->ts.type != BT_INTEGER || e->rank > 0)
+           {
+             gfc_free_expr (e);
+             return MATCH_NO;
+           }
+
+         gfc_next_char (); /* Burn the ')'. */
+         ts->kind = (int) mpz_get_si (e->value.integer);
+         if (gfc_validate_kind (BT_REAL, ts->kind , true) == -1)
+           {
+             gfc_error ("Invalid type-spec at %C");
+             return MATCH_ERROR;
+           }
+
+         gfc_free_expr (e);
+
+         return MATCH_YES;
+       }
+    }
+
   /* If a type is not matched, simply return MATCH_NO.  */
   gfc_current_locus = old_locus;
   return MATCH_NO;
@@ -2060,6 +2151,8 @@ gfc_match_type_spec (gfc_typespec *ts)
 kind_selector:
 
   gfc_gobble_whitespace ();
+
+  /* This prevents INTEGER*4, etc.  */
   if (gfc_peek_ascii_char () == '*')
     {
       gfc_error ("Invalid type-spec at %C");
@@ -2068,13 +2161,9 @@ kind_selector:
 
   m = gfc_match_kind_spec (ts, false);
 
+  /* No kind specifier found.  */
   if (m == MATCH_NO)
-    m = MATCH_YES;             /* No kind specifier found.  */
-
-  /* gfortran may have matched REAL(a=1), which is the keyword form of the
-     intrinsic procedure.  */
-  if (ts->type == BT_REAL && m == MATCH_ERROR)
-    m = MATCH_NO;
+    m = MATCH_YES;
 
   return m;
 }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8178f8dc727c4b363aa2cc89f8eac3202f1a059b..6d2c80f372bae668da6cfa3f8eee7d2b2f7451d0 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2016-10-23  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+       PR fortran/54730
+       PR fortran/78033
+       * gfortran.dg/pr78033.f90: New test.
+
 2016-10-23  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/69834

diff --git a/gcc/testsuite/gfortran.dg/pr78033.f90 b/gcc/testsuite/gfortran.dg/pr78033.f90
new file mode 100644 (file)
index 0000000..ce794b3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr78033.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+subroutine f(n, x, y)
+
+   implicit none
+
+   integer, parameter :: knd = kind(1.e0)
+
+   integer, intent(in) :: n
+   complex(knd), intent(in) :: x(1:n)
+
+   integer i
+   real(knd) y(2*n)
+   
+   y = [real(x), aimag(x)]
+   y = [real(x(1:n)), aimag(x(1:n))]
+   y = [real(knd) :: 1] 
+   y = [real(kind=42) :: 1] { dg-error "Invalid type-spec" }
+   y = [real(kind=knd) :: 1]
+   y = [real(kind=knd, a=1.)]
+   y = [real(a=1.)]
+   y = [real(a=1, kind=knd)]
+
+end subroutine f