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

comparison gcc/fortran/simplify.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
 /* Simplify intrinsic functions at compile-time.
-Copyright (C) 2000-2018 Free Software Foundation, Inc.
+Copyright (C) 2000-2020 Free Software Foundation, Inc.
 Contributed by Andy Vaught & Katherine Holcomb
 This file is part of GCC.
 GCC is free software; you can redistribute it and/or modify it under
 mpz_clear (mask);
 }
 else
 {
-/* Confirm that no bits above the signed range are set.  */
+/* Confirm that no bits above the signed range are set if we
-gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
+	 are doing range checking.  */
+if (flag_range_check != 0)
+	gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
 }
 }
 /* Converts an mpz_t unsigned variable into a signed one, assuming
 mpz_neg (x, x);
 mpz_clear (mask);
 }
-}
-/* In-place convert BOZ to REAL of the specified kind.  */
-static gfc_expr *
-convert_boz (gfc_expr *x, int kind)
-{
-if (x && x->ts.type == BT_INTEGER && x->is_boz)
-{
-gfc_typespec ts;
-gfc_clear_ts (&ts);
-ts.type = BT_REAL;
-ts.kind = kind;
-if (!gfc_convert_boz (x, &ts))
-	return &gfc_bad_expr;
-}
-return x;
 }
 /* Test that the expression is a constant array, simplifying if
 we are dealing with a parameter array.  */
 {
 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
 	if (*src)
 	  *dest = op (*dest, gfc_copy_expr (*src));
+if (post_op)
+	*dest = post_op (*dest, *dest);
 count[0]++;
 base += sstride[0];
 dest += dstride[0];
 n = 0;
 /* Place updated expression in result constructor.  */
 result_ctor = gfc_constructor_first (result->value.constructor);
 for (i = 0; i < resultsize; ++i)
 {
-if (post_op)
+result_ctor->expr = resultvec[i];
-	result_ctor->expr = post_op (result_ctor->expr, resultvec[i]);
-else
-	result_ctor->expr = resultvec[i];
 result_ctor = gfc_constructor_next (result_ctor);
 }
 free (arrayvec);
 free (resultvec);
 static gfc_expr *
 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
 {
 gfc_expr *result;
-if (convert_boz (x, kind) == &gfc_bad_expr)
-return &gfc_bad_expr;
-if (convert_boz (y, kind) == &gfc_bad_expr)
-return &gfc_bad_expr;
 if (x->expr_type != EXPR_CONSTANT
 || (y != NULL && y->expr_type != EXPR_CONSTANT))
 return NULL;
 }
 /* Convert a floating-point number from radians to degrees.  */
 static void
-degrees_f (mpfr_t x, mp_rnd_t rnd_mode)
+degrees_f (mpfr_t x, mpfr_rnd_t rnd_mode)
 {
 mpfr_t tmp;
 mpfr_init (tmp);
 /* Set x = x % 2pi to avoid offsets with large angles.  */
 }
 /* Convert a floating-point number from degrees to radians.  */
 static void
-radians_f (mpfr_t x, mp_rnd_t rnd_mode)
+radians_f (mpfr_t x, mpfr_rnd_t rnd_mode)
 {
 mpfr_t tmp;
 mpfr_init (tmp);
 /* Set x = x % 360 to avoid offsets with large angles.  */
 gfc_expr *
 gfc_simplify_dble (gfc_expr *e)
 {
 gfc_expr *result = NULL;
+int tmp1, tmp2;
 if (e->expr_type != EXPR_CONSTANT)
 return NULL;
-if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
+/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
-return &gfc_bad_expr;
+warnings.  */
+tmp1 = warn_conversion;
+tmp2 = warn_conversion_extra;
+warn_conversion = warn_conversion_extra = 0;
 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
+warn_conversion = tmp1;
+warn_conversion_extra = tmp2;
 if (result == &gfc_bad_expr)
 return &gfc_bad_expr;
 return range_check (result, "DBLE");
 }
 using a large precision for intermediate results.  This is used for all
 but large values of the argument.  */
 static void
 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
 {
-mp_prec_t prec;
+mpfr_prec_t prec;
 mpfr_t a, b;
 prec = mpfr_get_default_prec ();
 mpfr_set_default_prec (10 * prec);
 static void
 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
 {
 mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
 mpz_t num;
-mp_prec_t prec;
+mpfr_prec_t prec;
 unsigned i;
 prec = mpfr_get_default_prec ();
 mpfr_set_default_prec (2 * prec);
 gfc_expr *result;
 if (a->expr_type != EXPR_CONSTANT)
 return NULL;
-if (a->is_boz)
+result = gfc_int2real (a, gfc_default_real_kind);
-{
-if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
-	return &gfc_bad_expr;
-result = gfc_copy_expr (a);
-}
-else
-result = gfc_int2real (a, gfc_default_real_kind);
 return range_check (result, "FLOAT");
 }
 gfc_expr *
 gfc_simplify_fraction (gfc_expr *x)
 {
 gfc_expr *result;
-#if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
-mpfr_t absv, exp, pow2;
-#else
 mpfr_exp_t e;
-#endif
 if (x->expr_type != EXPR_CONSTANT)
 return NULL;
 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
 {
 mpfr_set_nan (result->value.real);
 return result;
 }
-#if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
-/* MPFR versions before 3.1.0 do not include mpfr_frexp.
-TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
-if (mpfr_sgn (x->value.real) == 0)
-{
-mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
-return result;
-}
-gfc_set_model_kind (x->ts.kind);
-mpfr_init (exp);
-mpfr_init (absv);
-mpfr_init (pow2);
-mpfr_abs (absv, x->value.real, GFC_RND_MODE);
-mpfr_log2 (exp, absv, GFC_RND_MODE);
-mpfr_trunc (exp, exp);
-mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
-mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
-mpfr_div (result->value.real, x->value.real, pow2, GFC_RND_MODE);
-mpfr_clears (exp, absv, pow2, NULL);
-#else
 /* mpfr_frexp() correctly handles zeros and NaNs.  */
 mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
-#endif
 return range_check (result, "FRACTION");
 }
 static gfc_expr *
 simplify_intconv (gfc_expr *e, int kind, const char *name)
 {
 gfc_expr *result = NULL;
+int tmp1, tmp2;
+/* Convert BOZ to integer, and return without range checking.  */
+if (e->ts.type == BT_BOZ)
+{
+if (!gfc_boz2int (e, kind))
+	return NULL;
+result = gfc_copy_expr (e);
+return result;
+}
 if (e->expr_type != EXPR_CONSTANT)
 return NULL;
+/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
+warnings.  */
+tmp1 = warn_conversion;
+tmp2 = warn_conversion_extra;
+warn_conversion = warn_conversion_extra = 0;
 result = gfc_convert_constant (e, BT_INTEGER, kind);
+warn_conversion = tmp1;
+warn_conversion_extra = tmp2;
 if (result == &gfc_bad_expr)
 return &gfc_bad_expr;
 return range_check (result, name);
 }
 	case REF_COMPONENT:
 	  as = ref->u.c.component->as;
 	  continue;
 	case REF_SUBSTRING:
+	case REF_INQUIRY:
 	  continue;
 	}
 }
 gcc_unreachable ();
 	case REF_COMPONENT:
 	  as = ref->u.c.component->as;
 	  continue;
 	case REF_SUBSTRING:
+	case REF_INQUIRY:
 	  continue;
 	}
 }
 if (!as)
 	   && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
 /* The expression in assoc->target points to a ref to the _data component
 of the unlimited polymorphic entity.  To get the _len component the last
 _data ref needs to be stripped and a ref to the _len component added.  */
-return gfc_get_len_component (e->symtree->n.sym->assoc->target);
+return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
 else
 return NULL;
 }
 mpz_init_set_si (result->shape[1], result_columns);
 }
 else
 gcc_unreachable();
-offset_a = offset_b = 0;
+offset_b = 0;
 for (col = 0; col < result_columns; ++col)
 {
 offset_a = 0;
 for (row = 0; row < result_rows; ++row)
 {
 gfc_expr * result;
 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
 if (mask->expr_type == EXPR_CONSTANT)
-return gfc_get_parentheses (gfc_copy_expr (mask->value.logical
+{
-					       ? tsource : fsource));
+result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
+/* Parenthesis is needed to get lower bounds of 1.  */
+result = gfc_get_parentheses (result);
+gfc_simplify_expr (result, 1);
+return result;
+}
 if (!mask->rank || !is_constant_array_expr (mask)
 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
 return NULL;
 static gfc_expr *
 simplify_min_max (gfc_expr *expr, int sign)
 {
 gfc_actual_arglist *arg, *last, *extremum;
-gfc_intrinsic_sym * specific;
+gfc_expr *tmp, *ret;
+const char *fname;
 last = NULL;
 extremum = NULL;
-specific = expr->value.function.isym;
 arg = expr->value.function.actual;
 for (; arg; last = arg, arg = arg->next)
 {
 /* If there is one value left, replace the function call with the
 expression.  */
 if (expr->value.function.actual->next != NULL)
 return NULL;
-/* Convert to the correct type and kind.  */
+/* Handle special cases of specific functions (min|max)1 and
-if (expr->ts.type != BT_UNKNOWN)
+a(min|max)0.  */
-return gfc_convert_constant (expr->value.function.actual->expr,
-	expr->ts.type, expr->ts.kind);
+tmp = expr->value.function.actual->expr;
+fname = expr->value.function.isym->name;
-if (specific->ts.type != BT_UNKNOWN)
-return gfc_convert_constant (expr->value.function.actual->expr,
+if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
-	specific->ts.type, specific->ts.kind);
+&& (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
+{
-return gfc_copy_expr (expr->value.function.actual->expr);
+ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
+}
+else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
+	   && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
+{
+ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
+}
+else
+ret = gfc_copy_expr (tmp);
+return ret;
 }
 gfc_expr *
 gfc_simplify_min (gfc_expr *e)
 return result;
 }
 /* Simplify minloc and maxloc for constant arrays.  */
-gfc_expr *
+static gfc_expr *
 gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
 			gfc_expr *kind, gfc_expr *back, int sign)
 {
 gfc_expr *result;
 gfc_expr *extremum;
 if (back->expr_type != EXPR_CONSTANT)
 	return NULL;
 back_val = back->value.logical;
 }
 if (sign < 0)
 init_val = INT_MAX;
 else if (sign > 0)
 init_val = INT_MIN;
 else
 gfc_expr *
 gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
 		     gfc_expr *back)
 {
 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
+}
+/* Simplify findloc to scalar.  Similar to
+simplify_minmaxloc_to_scalar.  */
+static gfc_expr *
+simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
+			    gfc_expr *mask, int back_val)
+{
+gfc_expr *a, *m;
+gfc_constructor *array_ctor, *mask_ctor;
+mpz_t count;
+mpz_set_si (result->value.integer, 0);
+/* Shortcut for constant .FALSE. MASK.  */
+if (mask
+&& mask->expr_type == EXPR_CONSTANT
+&& !mask->value.logical)
+return result;
+array_ctor = gfc_constructor_first (array->value.constructor);
+if (mask && mask->expr_type == EXPR_ARRAY)
+mask_ctor = gfc_constructor_first (mask->value.constructor);
+else
+mask_ctor = NULL;
+mpz_init_set_si (count, 0);
+while (array_ctor)
+{
+mpz_add_ui (count, count, 1);
+a = array_ctor->expr;
+array_ctor = gfc_constructor_next (array_ctor);
+/* A constant MASK equals .TRUE. here and can be ignored.  */
+if (mask_ctor)
+	{
+	  m = mask_ctor->expr;
+	  mask_ctor = gfc_constructor_next (mask_ctor);
+	  if (!m->value.logical)
+	    continue;
+	}
+if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
+	{
+	  /* We have a match.  If BACK is true, continue so we find
+	     the last one.  */
+	  mpz_set (result->value.integer, count);
+	  if (!back_val)
+	    break;
+	}
+}
+mpz_clear (count);
+return result;
+}
+/* Simplify findloc in the absence of a dim argument.  Similar to
+simplify_minmaxloc_nodim.  */
+static gfc_expr *
+simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
+			gfc_expr *mask, bool back_val)
+{
+ssize_t res[GFC_MAX_DIMENSIONS];
+int i, n;
+gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
+ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+sstride[GFC_MAX_DIMENSIONS];
+gfc_expr *a, *m;
+bool continue_loop;
+bool ma;
+for (i = 0; i<array->rank; i++)
+res[i] = -1;
+/* Shortcut for constant .FALSE. MASK.  */
+if (mask
+&& mask->expr_type == EXPR_CONSTANT
+&& !mask->value.logical)
+goto finish;
+for (i = 0; i < array->rank; i++)
+{
+count[i] = 0;
+sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
+extent[i] = mpz_get_si (array->shape[i]);
+if (extent[i] <= 0)
+	goto finish;
+}
+continue_loop = true;
+array_ctor = gfc_constructor_first (array->value.constructor);
+if (mask && mask->rank > 0)
+mask_ctor = gfc_constructor_first (mask->value.constructor);
+else
+mask_ctor = NULL;
+/* Loop over the array elements (and mask), keeping track of
+the indices to return.  */
+while (continue_loop)
+{
+do
+	{
+	  a = array_ctor->expr;
+	  if (mask_ctor)
+	    {
+	      m = mask_ctor->expr;
+	      ma = m->value.logical;
+	      mask_ctor = gfc_constructor_next (mask_ctor);
+	    }
+	  else
+	    ma = true;
+	  if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
+	    {
+	      for (i = 0; i<array->rank; i++)
+		res[i] = count[i];
+	      if (!back_val)
+		goto finish;
+	    }
+	  array_ctor = gfc_constructor_next (array_ctor);
+	  count[0] ++;
+	} while (count[0] != extent[0]);
+n = 0;
+do
+	{
+	  /* When we get to the end of a dimension, reset it and increment
+	     the next dimension.  */
+	  count[n] = 0;
+	  n++;
+	  if (n >= array->rank)
+	    {
+	      continue_loop = false;
+	      break;
+	    }
+	  else
+	    count[n] ++;
+	} while (count[n] == extent[n]);
+}
+finish:
+result_ctor = gfc_constructor_first (result->value.constructor);
+for (i = 0; i<array->rank; i++)
+{
+gfc_expr *r_expr;
+r_expr = result_ctor->expr;
+mpz_set_si (r_expr->value.integer, res[i] + 1);
+result_ctor = gfc_constructor_next (result_ctor);
+}
+return result;
+}
+/* Simplify findloc to an array.  Similar to
+simplify_minmaxloc_to_array.  */
+static gfc_expr *
+simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
+			   gfc_expr *dim, gfc_expr *mask, bool back_val)
+{
+mpz_t size;
+int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
+gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
+gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
+int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
+tmpstride[GFC_MAX_DIMENSIONS];
+/* Shortcut for constant .FALSE. MASK.  */
+if (mask
+&& mask->expr_type == EXPR_CONSTANT
+&& !mask->value.logical)
+return result;
+/* Build an indexed table for array element expressions to minimize
+linked-list traversal. Masked elements are set to NULL.  */
+gfc_array_size (array, &size);
+arraysize = mpz_get_ui (size);
+mpz_clear (size);
+arrayvec = XCNEWVEC (gfc_expr*, arraysize);
+array_ctor = gfc_constructor_first (array->value.constructor);
+mask_ctor = NULL;
+if (mask && mask->expr_type == EXPR_ARRAY)
+mask_ctor = gfc_constructor_first (mask->value.constructor);
+for (i = 0; i < arraysize; ++i)
+{
+arrayvec[i] = array_ctor->expr;
+array_ctor = gfc_constructor_next (array_ctor);
+if (mask_ctor)
+	{
+	  if (!mask_ctor->expr->value.logical)
+	    arrayvec[i] = NULL;
+	  mask_ctor = gfc_constructor_next (mask_ctor);
+	}
+}
+/* Same for the result expression.  */
+gfc_array_size (result, &size);
+resultsize = mpz_get_ui (size);
+mpz_clear (size);
+resultvec = XCNEWVEC (gfc_expr*, resultsize);
+result_ctor = gfc_constructor_first (result->value.constructor);
+for (i = 0; i < resultsize; ++i)
+{
+resultvec[i] = result_ctor->expr;
+result_ctor = gfc_constructor_next (result_ctor);
+}
+gfc_extract_int (dim, &dim_index);
+dim_index -= 1;	/* Zero-base index.  */
+dim_extent = 0;
+dim_stride = 0;
+for (i = 0, n = 0; i < array->rank; ++i)
+{
+count[i] = 0;
+tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
+if (i == dim_index)
+	{
+	  dim_extent = mpz_get_si (array->shape[i]);
+	  dim_stride = tmpstride[i];
+	  continue;
+	}
+extent[n] = mpz_get_si (array->shape[i]);
+sstride[n] = tmpstride[i];
+dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
+n += 1;
+}
+done = resultsize <= 0;
+base = arrayvec;
+dest = resultvec;
+while (!done)
+{
+for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
+	{
+	  if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
+	    {
+	      mpz_set_si ((*dest)->value.integer, n + 1);
+	      if (!back_val)
+		break;
+	    }
+	}
+count[0]++;
+base += sstride[0];
+dest += dstride[0];
+n = 0;
+while (!done && count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  base -= sstride[n] * extent[n];
+	  dest -= dstride[n] * extent[n];
+	  n++;
+	  if (n < result->rank)
+	    {
+	      /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
+		 times, we'd warn for the last iteration, because the
+		 array index will have already been incremented to the
+		 array sizes, and we can't tell that this must make
+		 the test against result->rank false, because ranks
+		 must not exceed GFC_MAX_DIMENSIONS.  */
+	      GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
+	      count[n]++;
+	      base += sstride[n];
+	      dest += dstride[n];
+	      GCC_DIAGNOSTIC_POP
+	    }
+	  else
+	    done = true;
+}
+}
+/* Place updated expression in result constructor.  */
+result_ctor = gfc_constructor_first (result->value.constructor);
+for (i = 0; i < resultsize; ++i)
+{
+result_ctor->expr = resultvec[i];
+result_ctor = gfc_constructor_next (result_ctor);
+}
+free (arrayvec);
+free (resultvec);
+return result;
+}
+/* Simplify findloc.  */
+gfc_expr *
+gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
+		      gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
+{
+gfc_expr *result;
+int ikind;
+bool back_val = false;
+if (!is_constant_array_expr (array)
+|| !gfc_is_constant_expr (dim))
+return NULL;
+if (! gfc_is_constant_expr (value))
+return 0;
+if (mask
+&& !is_constant_array_expr (mask)
+&& mask->expr_type != EXPR_CONSTANT)
+return NULL;
+if (kind)
+{
+if (gfc_extract_int (kind, &ikind, -1))
+	return NULL;
+}
+else
+ikind = gfc_default_integer_kind;
+if (back)
+{
+if (back->expr_type != EXPR_CONSTANT)
+	return NULL;
+back_val = back->value.logical;
+}
+if (dim)
+{
+result = transformational_result (array, dim, BT_INTEGER,
+					ikind, &array->where);
+init_result_expr (result, 0, array);
+if (array->rank == 1)
+	return simplify_findloc_to_scalar (result, array, value, mask,
+					   back_val);
+else
+	return simplify_findloc_to_array (result, array, value, dim, mask,
+					  back_val);
+}
+else
+{
+result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
+return simplify_findloc_nodim (result, value, array, mask, back_val);
+}
+return NULL;
 }
 gfc_expr *
 gfc_simplify_maxexponent (gfc_expr *x)
 {
 gfc_expr *
 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
 {
 gfc_expr *result;
-mp_exp_t emin, emax;
+mpfr_exp_t emin, emax;
 int kind;
 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
 return NULL;
 emin = mpfr_get_emin ();
 emax = mpfr_get_emax ();
 /* Set emin and emax for the current model number.  */
 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
-mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
+mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
 		mpfr_get_prec(result->value.real) + 1);
-mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
+mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent - 1);
-mpfr_check_range (result->value.real, 0, GMP_RNDU);
+mpfr_check_range (result->value.real, 0, MPFR_RNDU);
 if (mpfr_sgn (s->value.real) > 0)
 {
 mpfr_nextabove (result->value.real);
-mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
+mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
 }
 else
 {
 mpfr_nextbelow (result->value.real);
-mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
+mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
 }
 mpfr_set_emin (emin);
 mpfr_set_emax (emax);
 gfc_simplify_idnint (gfc_expr *e)
 {
 return simplify_nint ("IDNINT", e, NULL);
 }
+static int norm2_scale;
 static gfc_expr *
-add_squared (gfc_expr *result, gfc_expr *e)
+norm2_add_squared (gfc_expr *result, gfc_expr *e)
 {
 mpfr_t tmp;
 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
 gcc_assert (result->ts.type == BT_REAL
 	      && result->expr_type == EXPR_CONSTANT);
 gfc_set_model_kind (result->ts.kind);
+int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
+mpfr_exp_t exp;
+if (mpfr_regular_p (result->value.real))
+{
+exp = mpfr_get_exp (result->value.real);
+/* If result is getting close to overflowing, scale down.  */
+if (exp >= gfc_real_kinds[index].max_exponent - 4
+	  && norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
+	{
+	  norm2_scale += 2;
+	  mpfr_div_ui (result->value.real, result->value.real, 16,
+		       GFC_RND_MODE);
+	}
+}
 mpfr_init (tmp);
-mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
+if (mpfr_regular_p (e->value.real))
+{
+exp = mpfr_get_exp (e->value.real);
+/* If e**2 would overflow or close to overflowing, scale down.  */
+if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
+	{
+	  int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
+	  mpfr_set_ui (tmp, 1, GFC_RND_MODE);
+	  mpfr_set_exp (tmp, new_scale - norm2_scale);
+	  mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
+	  mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
+	  norm2_scale = new_scale;
+	}
+}
+if (norm2_scale)
+{
+mpfr_set_ui (tmp, 1, GFC_RND_MODE);
+mpfr_set_exp (tmp, norm2_scale);
+mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
+}
+else
+mpfr_set (tmp, e->value.real, GFC_RND_MODE);
+mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
 mpfr_add (result->value.real, result->value.real, tmp,
 	    GFC_RND_MODE);
 mpfr_clear (tmp);
 return result;
 }
 static gfc_expr *
-do_sqrt (gfc_expr *result, gfc_expr *e)
+norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
 {
 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
 gcc_assert (result->ts.type == BT_REAL
 	      && result->expr_type == EXPR_CONSTANT);
-mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
+if (result != e)
+mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+if (norm2_scale && mpfr_regular_p (result->value.real))
+{
+mpfr_t tmp;
+mpfr_init (tmp);
+mpfr_set_ui (tmp, 1, GFC_RND_MODE);
+mpfr_set_exp (tmp, norm2_scale);
+mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
+mpfr_clear (tmp);
+}
+norm2_scale = 0;
 return result;
 }
 gfc_expr *
 init_result_expr (result, 0, NULL);
 if (size_zero)
 return result;
+norm2_scale = 0;
 if (!dim || e->rank == 1)
 {
 result = simplify_transformation_to_scalar (result, e, NULL,
-						  add_squared);
+						  norm2_add_squared);
 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+if (norm2_scale && mpfr_regular_p (result->value.real))
+	{
+	  mpfr_t tmp;
+	  mpfr_init (tmp);
+	  mpfr_set_ui (tmp, 1, GFC_RND_MODE);
+	  mpfr_set_exp (tmp, norm2_scale);
+	  mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
+	  mpfr_clear (tmp);
+	}
+norm2_scale = 0;
 }
 else
 result = simplify_transformation_to_array (result, e, dim, NULL,
-					       add_squared, &do_sqrt);
+					       norm2_add_squared,
+					       norm2_do_sqrt);
 return result;
 }
 result->value.logical = result->value.logical != e->value.logical;
 return result;
 }
+gfc_expr *
+gfc_simplify_is_contiguous (gfc_expr *array)
+{
+if (gfc_is_simply_contiguous (array, false, true))
+return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
+if (gfc_is_not_contiguous (array))
+return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
+return NULL;
+}
 gfc_expr *
 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
 {
 return simplify_transformation (e, dim, NULL, 0, do_xor);
 gfc_expr *
 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
 {
 gfc_expr *result = NULL;
-int kind;
+int kind, tmp1, tmp2;
+/* Convert BOZ to real, and return without range checking.  */
+if (e->ts.type == BT_BOZ)
+{
+/* Determine kind for conversion of the BOZ.  */
+if (k)
+	gfc_extract_int (k, &kind);
+else
+	kind = gfc_default_real_kind;
+if (!gfc_boz2real (e, kind))
+	return NULL;
+result = gfc_copy_expr (e);
+return result;
+}
 if (e->ts.type == BT_COMPLEX)
 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
 else
 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
 return &gfc_bad_expr;
 if (e->expr_type != EXPR_CONSTANT)
 return NULL;
-if (convert_boz (e, kind) == &gfc_bad_expr)
+/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
-return &gfc_bad_expr;
+warnings.  */
+tmp1 = warn_conversion;
+tmp2 = warn_conversion_extra;
+warn_conversion = warn_conversion_extra = 0;
 result = gfc_convert_constant (e, BT_REAL, kind);
+warn_conversion = tmp1;
+warn_conversion_extra = tmp2;
 if (result == &gfc_bad_expr)
 return &gfc_bad_expr;
 return range_check (result, "REAL");
 }
 /* Proceed with simplification, unpacking the array.  */
 mpz_init (index);
 rank = 0;
+for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+x[i] = 0;
 for (;;)
 {
 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
 if (e == NULL)
 	break;
 for (i = 0; i < rank; i++)
 	order[i] = i;
 }
 else
 {
-for (i = 0; i < rank; i++)
+mpz_t size;
-	x[i] = 0;
+int order_size, shape_size;
+if (order_exp->rank != shape_exp->rank)
+	{
+	  gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
+		     &order_exp->where, &shape_exp->where);
+	  return &gfc_bad_expr;
+	}
+gfc_array_size (shape_exp, &size);
+shape_size = mpz_get_ui (size);
+mpz_clear (size);
+gfc_array_size (order_exp, &size);
+order_size = mpz_get_ui (size);
+mpz_clear (size);
+if (order_size != shape_size)
+	{
+	  gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
+		     &order_exp->where, &shape_exp->where);
+	  return &gfc_bad_expr;
+	}
 for (i = 0; i < rank; i++)
 	{
 	  e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
 	  gcc_assert (e);
 	  gfc_extract_int (e, &order[i]);
-	  gcc_assert (order[i] >= 1 && order[i] <= rank);
+	  if (order[i] < 1 || order[i] > rank)
+	    {
+	      gfc_error ("Element with a value of %d in ORDER at %L must be "
+			 "in the range [1, ..., %d] for the RESHAPE intrinsic "
+			 "near %L", order[i], &order_exp->where, rank,
+			 &shape_exp->where);
+	      return &gfc_bad_expr;
+	    }
 	  order[i]--;
-	  gcc_assert (x[order[i]] == 0);
+	  if (x[order[i]] != 0)
+	    {
+	      gfc_error ("ORDER at %L is not a permutation of the size of "
+			 "SHAPE at %L", &order_exp->where, &shape_exp->where);
+	      return &gfc_bad_expr;
+	    }
 	  x[order[i]] = 1;
 	}
 }
 /* Count the elements in the source and padding arrays.  */
 			       c->value.character.string) + 1;
 	  if (indx > len)
 	    indx = 0;
 	}
 else
-	{
+	for (indx = len; indx > 0; indx--)
-	  i = 0;
+	  {
-	  for (indx = len; indx > 0; indx--)
+	    for (i = 0; i < lenc; i++)
-	    {
+	      {
-	      for (i = 0; i < lenc; i++)
+		if (c->value.character.string[i]
-		{
+		    == e->value.character.string[indx - 1])
-		  if (c->value.character.string[i]
+		  break;
-		      == e->value.character.string[indx - 1])
+	      }
-		    break;
+	    if (i < lenc)
-		}
+	      break;
-	      if (i < lenc)
+	  }
-		break;
-	    }
-	}
 }
 result = gfc_get_int_expr (k, &e->where, indx);
 return range_check (result, "SCAN");
 }
 gfc_expr *
 gfc_simplify_sizeof (gfc_expr *x)
 {
 gfc_expr *result = NULL;
 mpz_t array_size;
+size_t res_size;
 if (x->ts.type == BT_CLASS || x->ts.deferred)
 return NULL;
 if (x->ts.type == BT_CHARACTER
 && !gfc_array_size (x, &array_size))
 return NULL;
 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
 				  &x->where);
-mpz_set_si (result->value.integer, gfc_target_expr_size (x));
+gfc_target_expr_size (x, &res_size);
+mpz_set_si (result->value.integer, res_size);
 return result;
 }
 gfc_simplify_storage_size (gfc_expr *x,
 			   gfc_expr *kind)
 {
 gfc_expr *result = NULL;
 int k;
+size_t siz;
 if (x->ts.type == BT_CLASS || x->ts.deferred)
 return NULL;
 if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
 if (k == -1)
 return &gfc_bad_expr;
 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
-mpz_set_si (result->value.integer, gfc_element_size (x));
+gfc_element_size (x, &siz);
+mpz_set_si (result->value.integer, siz);
 mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
 return range_check (result, "STORAGE_SIZE");
 }
 gfc_expr *
 gfc_simplify_sngl (gfc_expr *a)
 {
 gfc_expr *result;
+int tmp1, tmp2;
 if (a->expr_type != EXPR_CONSTANT)
 return NULL;
+/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
+warnings.  */
+tmp1 = warn_conversion;
+tmp2 = warn_conversion_extra;
+warn_conversion = warn_conversion_extra = 0;
 result = gfc_real2real (a, gfc_default_real_kind);
+warn_conversion = tmp1;
+warn_conversion_extra = tmp2;
 return range_check (result, "SNGL");
 }
 gfc_expr *
 mpz_init_set_ui (size, 1);
 nelem = mpz_get_si (size) * ncopies;
 if (nelem > flag_max_array_constructor)
 {
-if (gfc_current_ns->sym_root->n.sym->attr.flavor == FL_PARAMETER)
+if (gfc_init_expr_flag)
 	{
 	  gfc_error ("The number of elements (%d) in the array constructor "
 		     "at %L requires an increase of the allowed %d upper "
 		     "limit.  See %<-fmax-array-constructor%> option.",
 		     nelem, &source->where, flag_max_array_constructor);
 	}
 else
 	return NULL;
 }
-if (source->expr_type == EXPR_CONSTANT)
+if (source->expr_type == EXPR_CONSTANT
+|| source->expr_type == EXPR_STRUCTURE)
 {
 gcc_assert (dim == 0);
 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
 				   &source->where);
 	  goto oops;
 	}
 break;
 case BT_CHARACTER:
-if (type == BT_CHARACTER)
+switch (type)
-	f = gfc_character2character;
+	{
-else
+	case BT_INTEGER:
-	goto oops;
+	  f = gfc_character2int;
+	  break;
+	case BT_REAL:
+	  f = gfc_character2real;
+	  break;
+	case BT_COMPLEX:
+	  f = gfc_character2complex;
+	  break;
+	case BT_CHARACTER:
+	  f = gfc_character2character;
+	  break;
+	case BT_LOGICAL:
+	  f = gfc_character2logical;
+	  break;
+	default:
+	  goto oops;
+	}
 break;
 default:
 oops:
-gfc_internal_error ("gfc_convert_constant(): Unexpected type");
+return &gfc_bad_expr;
 }
 result = NULL;
 switch (e->expr_type)
 	  gfc_expr *tmp;
 	  if (c->iterator == NULL)
 	    {
 	      if (c->expr->expr_type == EXPR_ARRAY)
 		tmp = gfc_convert_constant (c->expr, type, kind);
+	      else if (c->expr->expr_type == EXPR_OP)
+		{
+		  if (!gfc_simplify_expr (c->expr, 1))
+		    return &gfc_bad_expr;
+		  tmp = f (c->expr, kind);
+		}
 	      else
 		tmp = f (c->expr, kind);
 	    }
 	  else
 	    tmp = gfc_convert_constant (c->expr, type, kind);

Mercurial > hg > CbC > CbC_gcc

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