CbC/CbC_gcc: gcc/fortran/array.c comparison

comparison gcc/fortran/array.c @ 145:1830386684a0

gcc-9.2.0

author	anatofuz
date	Thu, 13 Feb 2020 11:34:05 +0900
parents	84e7813d76e9
children

comparison

equal deleted inserted replaced

-:84e7813d76e9
+:1830386684a0
 /* Array things
-Copyright (C) 2000-2018 Free Software Foundation, Inc.
+Copyright (C) 2000-2020 Free Software Foundation, Inc.
 Contributed by Andy Vaught
 This file is part of GCC.
 GCC is free software; you can redistribute it and/or modify it under
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
 #include "options.h"
 #include "gfortran.h"
+#include "parse.h"
 #include "match.h"
 #include "constructor.h"
 /**************** Array reference matching subroutines *****************/
 match_subscript (gfc_array_ref *ar, int init, bool match_star)
 {
 match m = MATCH_ERROR;
 bool star = false;
 int i;
+bool saw_boz = false;
 i = ar->dimen + ar->codimen;
 gfc_gobble_whitespace ();
 ar->c_where[i] = gfc_current_locus;
 if (!star && init)
 m = gfc_match_init_expr (&ar->start[i]);
 else if (!star)
 m = gfc_match_expr (&ar->start[i]);
+if (ar->start[i] && ar->start[i]->ts.type == BT_BOZ)
+{
+gfc_error ("Invalid BOZ literal constant used in subscript at %C");
+saw_boz = true;
+}
 if (m == MATCH_NO)
 gfc_error ("Expected array subscript at %C");
 if (m != MATCH_YES)
 return MATCH_ERROR;
 else if (init)
 m = gfc_match_init_expr (&ar->end[i]);
 else
 m = gfc_match_expr (&ar->end[i]);
+if (ar->end[i] && ar->end[i]->ts.type == BT_BOZ)
+{
+gfc_error ("Invalid BOZ literal constant used in subscript at %C");
+saw_boz = true;
+}
 if (m == MATCH_ERROR)
 return MATCH_ERROR;
 /* See if we have an optional stride.  */
 if (gfc_match_char (':') == MATCH_YES)
 	  return MATCH_ERROR;
 	}
 m = init ? gfc_match_init_expr (&ar->stride[i])
 	       : gfc_match_expr (&ar->stride[i]);
+if (ar->stride[i] && ar->stride[i]->ts.type == BT_BOZ)
+	{
+	  gfc_error ("Invalid BOZ literal constant used in subscript at %C");
+	  saw_boz = true;
+	}
 if (m == MATCH_NO)
 	gfc_error ("Expected array subscript stride at %C");
 if (m != MATCH_YES)
 	return MATCH_ERROR;
 matched:
 if (star)
 ar->dimen_type[i] = DIMEN_STAR;
-return MATCH_YES;
+return (saw_boz ? MATCH_ERROR : MATCH_YES);
 }
 /* Match an array reference, whether it is the whole array or particular
 elements or a section.  If init is set, the reference has to consist
 int i;
 if (as == NULL)
 return;
-for (i = 0; i < as->rank + as->corank; i++)
+if (as->corank == 0)
 {
-gfc_free_expr (as->lower[i]);
+for (i = 0; i < as->rank; i++)
-gfc_free_expr (as->upper[i]);
+	{
+	  gfc_free_expr (as->lower[i]);
+	  gfc_free_expr (as->upper[i]);
+	}
+}
+else
+{
+int n = as->rank + as->corank - (as->cotype == AS_EXPLICIT ? 1 : 0);
+for (i = 0; i < n; i++)
+	{
+	  gfc_free_expr (as->lower[i]);
+	  gfc_free_expr (as->upper[i]);
+	}
 }
 free (as);
 }
 if (as->resolved)
 return true;
 for (i = 0; i < as->rank + as->corank; i++)
 {
+if (i == GFC_MAX_DIMENSIONS)
+	return false;
 e = as->lower[i];
 if (!resolve_array_bound (e, check_constant))
 	return false;
 e = as->upper[i];
 	  {		/* See how current spec meshes with the existing.  */
 	  case AS_UNKNOWN:
 	    goto cleanup;
 	  case AS_IMPLIED_SHAPE:
-	    if (current_type != AS_ASSUMED_SHAPE)
+	    if (current_type != AS_ASSUMED_SIZE)
 	      {
 		gfc_error ("Bad array specification for implied-shape"
 			   " array at %C");
 		goto cleanup;
 	      }
 /* Something went wrong.  */
 gfc_free_array_spec (as);
 return MATCH_ERROR;
 }
 /* Given a symbol and an array specification, modify the symbol to
 have that array specification.  The error locus is needed in case
 something goes wrong.  On failure, the caller must free the spec.  */
 bool
 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
 {
 int i;
+symbol_attribute *attr;
 if (as == NULL)
 return true;
+/* If the symbol corresponds to a submodule module procedure the array spec is
+already set, so do not attempt to set it again here. */
+attr = &sym->attr;
+if (gfc_submodule_procedure(attr))
+return true;
 if (as->rank
 && !gfc_add_dimension (&sym->attr, sym->name, error_loc))
 return false;
 if (as->corank
 return false;
 }
 if (as->corank)
 {
-/* The "sym" has no corank (checked via gfc_add_codimension). Thus
-	 the codimension is simply added.  */
-gcc_assert (as->rank == 0 && sym->as->corank == 0);
 sym->as->cotype = as->cotype;
 sym->as->corank = as->corank;
+/* Check F2018:C822.  */
+if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
+	goto too_many;
 for (i = 0; i < as->corank; i++)
 	{
 	  sym->as->lower[sym->as->rank + i] = as->lower[i];
 	  sym->as->upper[sym->as->rank + i] = as->upper[i];
 	}
 sym->as->rank = as->rank;
 sym->as->type = as->type;
 sym->as->cray_pointee = as->cray_pointee;
 sym->as->cp_was_assumed = as->cp_was_assumed;
-for (i = 0; i < sym->as->corank; i++)
+/* Check F2018:C822.  */
+if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
+	goto too_many;
+for (i = sym->as->corank - 1; i >= 0; i--)
 	{
 	  sym->as->lower[as->rank + i] = sym->as->lower[i];
 	  sym->as->upper[as->rank + i] = sym->as->upper[i];
 	}
 for (i = 0; i < as->rank; i++)
 	}
 }
 free (as);
 return true;
+too_many:
+gfc_error ("rank + corank of %qs exceeds %d at %C", sym->name,
+	     GFC_MAX_DIMENSIONS);
+return false;
 }
 /* Copy an array specification.  */
 m = gfc_match_expr (&expr);
 if (m != MATCH_YES)
 return m;
+if (expr->ts.type == BT_BOZ)
+{
+gfc_error ("BOZ literal constant at %L cannot appear in an "
+		 "array constructor", &expr->where);
+goto done;
+}
 if (expr->expr_type == EXPR_FUNCTION
 && expr->ts.type == BT_UNKNOWN
 && strcmp(expr->symtree->name, "null") == 0)
 {
 gfc_error ("NULL() at %C cannot appear in an array constructor");
-gfc_free_expr (expr);
+goto done;
-return MATCH_ERROR;
+}
-}
 gfc_constructor_append_expr (result, expr, &gfc_current_locus);
 return MATCH_YES;
-}
+done:
+gfc_free_expr (expr);
+return MATCH_ERROR;
+}
+/* Convert components of an array constructor to the type in ts.  */
+static match
+walk_array_constructor (gfc_typespec *ts, gfc_constructor_base head)
+{
+gfc_constructor *c;
+gfc_expr *e;
+match m;
+for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
+{
+e = c->expr;
+if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_UNKNOWN
+	  && !e->ref && e->value.constructor)
+	{
+	  m = walk_array_constructor (ts, e->value.constructor);
+	  if (m == MATCH_ERROR)
+	    return m;
+	}
+else if (!gfc_convert_type_warn (e, ts, 1, 1, true)
+	       && e->ts.type != BT_UNKNOWN)
+	return MATCH_ERROR;
+}
+return MATCH_YES;
+}
 /* Match an array constructor.  */
 match
 gfc_match_array_constructor (gfc_expr **result)
 		  return MATCH_ERROR;
 		}
 	    }
 	}
-/* Walk the constructor and ensure type conversion for numeric types.  */
+/* Walk the constructor, and if possible, do type conversion for
+	 numeric types.  */
 if (gfc_numeric_ts (&ts))
 	{
-	  c = gfc_constructor_first (head);
+	  m = walk_array_constructor (&ts, head);
-	  for (; c; c = gfc_constructor_next (c))
+	  if (m == MATCH_ERROR)
-	    gfc_convert_type (c->expr, &ts, 1);
+	    return m;
 	}
 }
 else
 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
 if (gfc_compare_types (&constructor_ts, &expr->ts))
 return 0;
 if (convert)
-return gfc_convert_type(expr, &constructor_ts, 1) ? 0 : 1;
+return gfc_convert_type_warn (expr, &constructor_ts, 1, 1, true) ? 0 : 1;
 gfc_error ("Element in %s array constructor at %L is %s",
 	     gfc_typename (&constructor_ts), &expr->where,
-	     gfc_typename (&expr->ts));
+	     gfc_typename (expr));
 cons_state = CONS_BAD;
 return 1;
 }
 iter_stack = frame.prev;
 return t;
 }
+/* Variables for noticing if all constructors are empty, and
+if any of them had a type.  */
+static bool empty_constructor;
+static gfc_typespec empty_ts;
 /* Expand a constructor into constant constructors without any
 iterators, calling the work function for each of the expanded
 expressions.  The work function needs to either save or free the
 passed expression.  */
 	  continue;
 	}
 e = c->expr;
+if (empty_constructor)
+	empty_ts = e->ts;
 if (e->expr_type == EXPR_ARRAY)
 	{
 	  if (!expand_constructor (e->value.constructor))
 	    return false;
 	  continue;
 	}
+empty_constructor = false;
 e = gfc_copy_expr (e);
 if (!gfc_simplify_expr (e, 1))
 	{
 	  gfc_free_expr (e);
 	  return false;
 	}
+e->from_constructor = 1;
 current_expand.offset = &c->offset;
 current_expand.repeat = &c->repeat;
 current_expand.component = c->n.component;
 if (!current_expand.expand_work_function(e))
 	return false;
 expand_save = current_expand;
 current_expand.base = NULL;
 iter_stack = NULL;
+empty_constructor = true;
+gfc_clear_ts (&empty_ts);
 current_expand.expand_work_function = expand;
 if (!expand_constructor (e->value.constructor))
 {
 gfc_constructor_free (current_expand.base);
 rc = false;
 goto done;
 }
+/* If we don't have an explicit constructor type, and there
+were only empty constructors, then take the type from
+them.  */
+if (constructor_ts.type == BT_UNKNOWN && empty_constructor)
+e->ts = empty_ts;
 gfc_constructor_free (e->value.constructor);
 e->value.constructor = current_expand.base;
 rc = true;
 dest->var = gfc_copy_expr (src->var);
 dest->start = gfc_copy_expr (src->start);
 dest->end = gfc_copy_expr (src->end);
 dest->step = gfc_copy_expr (src->step);
 dest->unroll = src->unroll;
+dest->ivdep = src->ivdep;
+dest->vector = src->vector;
+dest->novector = src->novector;
 return dest;
 }
 if (dimen < 0 || dimen > as->rank - 1)
 gfc_internal_error ("spec_dimen_size(): Bad dimension");
 if (as->type != AS_EXPLICIT
-|| as->lower[dimen]->expr_type != EXPR_CONSTANT
+|| !as->lower[dimen]
+|| !as->upper[dimen])
+return false;
+if (as->lower[dimen]->expr_type != EXPR_CONSTANT
 || as->upper[dimen]->expr_type != EXPR_CONSTANT
 || as->lower[dimen]->ts.type != BT_INTEGER
 || as->upper[dimen]->ts.type != BT_INTEGER)
 return false;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/array.c @ 145:1830386684a0