Re: [PATCH] PR fortran/78033 -- This was a REAL pain

[Steve Kargl <sgk at troutmask dot apl dot washington dot edu>]

On Sat, Oct 22, 2016 at 08:55:46AM +0200, Paul Richard Thomas wrote:
> 
> Thanks for persevering with this. The patch looks good to me. If it
> has regtested OK, please feel free to commit.
> 

The attached patch is the final version, which I just committed.

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.

-- 
Steve

Index: gcc/fortran/array.c
===================================================================
--- gcc/fortran/array.c	(revision 241448)
+++ gcc/fortran/array.c	(working copy)
@@ -1091,7 +1091,6 @@ gfc_match_array_constructor (gfc_expr **
 {
   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 **
   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 **
     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 **
 	{
 	  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 **
 	    {
 	      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)
     {
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 241448)
+++ gcc/fortran/match.c	(working copy)
@@ -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;
 }
Index: gcc/testsuite/gfortran.dg/pr78033.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr78033.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/pr78033.f90	(working copy)
@@ -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