gcc-7.1.0gcc-7.1.0

1 files changed, 54 insertions, 32 deletions

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 1430e80251..ec0c26656f 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1,5 +1,5 @@
 /* Array things
-   Copyright (C) 2000-2016 Free Software Foundation, Inc.
+   Copyright (C) 2000-2017 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -156,6 +156,8 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
 {
   match m;
   bool matched_bracket = false;
+  gfc_expr *tmp;
+  bool stat_just_seen = false;
 
   memset (ar, '\0', sizeof (*ar));
 
@@ -220,12 +222,27 @@ coarray:
 	return MATCH_ERROR;
     }
 
+  ar->stat = NULL;
+
   for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
     {
       m = match_subscript (ar, init, true);
       if (m == MATCH_ERROR)
 	return MATCH_ERROR;
 
+      stat_just_seen = false;
+      if (gfc_match(" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL)
+	{
+	  ar->stat = tmp;
+	  stat_just_seen = true;
+	}
+
+      if (ar->stat && !stat_just_seen)
+	{
+	  gfc_error ("STAT= attribute in %C misplaced");
+	  return MATCH_ERROR;
+	}
+
       if (gfc_match_char (']') == MATCH_YES)
 	{
 	  ar->codimen++;
@@ -1072,8 +1089,8 @@ match_array_cons_element (gfc_constructor_base *result)
 match
 gfc_match_array_constructor (gfc_expr **result)
 {
-  gfc_constructor_base head, new_cons;
-  gfc_undo_change_set changed_syms;
+  gfc_constructor *c;
+  gfc_constructor_base head;
   gfc_expr *expr;
   gfc_typespec ts;
   locus where;
@@ -1081,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)
@@ -1097,12 +1117,9 @@ gfc_match_array_constructor (gfc_expr **result)
     end_delim = " /)";
 
   where = gfc_current_locus;
-  head = new_cons = 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)
     {
@@ -1112,33 +1129,29 @@ gfc_match_array_constructor (gfc_expr **result)
 	{
 	  if (!gfc_notify_std (GFC_STD_F2003, "Array constructor "
 			       "including type specification at %C"))
+	    goto cleanup;
+
+	  if (ts.deferred)
 	    {
-	      gfc_restore_last_undo_checkpoint ();
+	      gfc_error ("Type-spec at %L cannot contain a deferred "
+			 "type parameter", &where);
 	      goto cleanup;
 	    }
 
-	  if (ts.deferred)
+	  if (ts.type == BT_CHARACTER
+	      && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec)
 	    {
-	      gfc_error ("Type-spec at %L cannot contain a deferred "
+	      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)
     {
@@ -1177,8 +1190,6 @@ done:
 	 be converted.  See PR fortran/67803.  */
       if (ts.type == BT_CHARACTER)
 	{
-	  gfc_constructor *c;
-
 	  c = gfc_constructor_first (head);
 	  for (; c; c = gfc_constructor_next (c))
 	    {
@@ -1201,6 +1212,14 @@ done:
 		}
 	    }
 	}
+
+      /* Walk the constructor and ensure type conversion for numeric types.  */
+      if (gfc_numeric_ts (&ts))
+	{
+	  c = gfc_constructor_first (head);
+	  for (; c; c = gfc_constructor_next (c))
+	    gfc_convert_type (c->expr, &ts, 1);
+	}
     }
   else
     expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
@@ -2544,7 +2563,7 @@ cleanup:
    characterizes the reference.  */
 
 gfc_array_ref *
-gfc_find_array_ref (gfc_expr *e)
+gfc_find_array_ref (gfc_expr *e, bool allow_null)
 {
   gfc_ref *ref;
 
@@ -2554,7 +2573,12 @@ gfc_find_array_ref (gfc_expr *e)
       break;
 
   if (ref == NULL)
-    gfc_internal_error ("gfc_find_array_ref(): No ref found");
+    {
+      if (allow_null)
+	return NULL;
+      else
+	gfc_internal_error ("gfc_find_array_ref(): No ref found");
+    }
 
   return &ref->u.ar;
 }
@@ -2562,18 +2586,16 @@ gfc_find_array_ref (gfc_expr *e)
 
 /* Find out if an array shape is known at compile time.  */
 
-int
+bool
 gfc_is_compile_time_shape (gfc_array_spec *as)
 {
-  int i;
-
   if (as->type != AS_EXPLICIT)
-    return 0;
+    return false;
 
-  for (i = 0; i < as->rank; i++)
+  for (int i = 0; i < as->rank; i++)
     if (!gfc_is_constant_expr (as->lower[i])
 	|| !gfc_is_constant_expr (as->upper[i]))
-      return 0;
+      return false;
 
-  return 1;
+  return true;
 }