1 files changed, 316 insertions, 15 deletions

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index ecea1c3a71..b784ac339e 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1,5 +1,5 @@
 /* Intrinsic function resolution.
-   Copyright (C) 2000-2016 Free Software Foundation, Inc.
+   Copyright (C) 2000-2017 Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -47,15 +47,27 @@ const char *
 gfc_get_string (const char *format, ...)
 {
   char temp_name[128];
+  const char *str;
   va_list ap;
   tree ident;
 
-  va_start (ap, format);
-  vsnprintf (temp_name, sizeof (temp_name), format, ap);
-  va_end (ap);
-  temp_name[sizeof (temp_name) - 1] = 0;
+  /* Handle common case without vsnprintf and temporary buffer.  */
+  if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
+    {
+      va_start (ap, format);
+      str = va_arg (ap, const char *);
+      va_end (ap);
+    }
+  else
+    {
+      va_start (ap, format);
+      vsnprintf (temp_name, sizeof (temp_name), format, ap);
+      va_end (ap);
+      temp_name[sizeof (temp_name) - 1] = 0;
+      str = temp_name;
+    }
 
-  ident = get_identifier (temp_name);
+  ident = get_identifier (str);
   return IDENTIFIER_POINTER (ident);
 }
 
@@ -141,7 +153,7 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
 	}
     }
 
-  f->value.function.name = gfc_get_string (name);
+  f->value.function.name = gfc_get_string ("%s", name);
 }
 
 
@@ -174,7 +186,7 @@ resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
 
   f->value.function.name
     = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
-		    gfc_type_letter (array->ts.type), array->ts.kind);
+		      gfc_type_letter (array->ts.type), array->ts.kind);
 }
 
 
@@ -229,7 +241,7 @@ gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
 
 static void
 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
-			const char *name)
+			bool is_achar)
 {
   f->ts.type = BT_CHARACTER;
   f->ts.kind = (kind == NULL)
@@ -237,16 +249,16 @@ gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
   f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
   f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 
-  f->value.function.name = gfc_get_string (name, f->ts.kind,
-					   gfc_type_letter (x->ts.type),
-					   x->ts.kind);
+  f->value.function.name
+    = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
+		      gfc_type_letter (x->ts.type), x->ts.kind);
 }
 
 
 void
 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
 {
-  gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
+  gfc_resolve_char_achar (f, x, kind, true);
 }
 
 
@@ -536,7 +548,7 @@ gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 void
 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
-  gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
+  gfc_resolve_char_achar (f, a, kind, false);
 }
 
 
@@ -673,6 +685,86 @@ gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
 }
 
 
+/* Our replacement of elements of a trig call with an EXPR_OP (e.g.
+   multiplying the result or operands by a factor to convert to/from degrees)
+   will cause the resolve_* function to be invoked again when resolving the
+   freshly created EXPR_OP.  See gfc_resolve_trigd, gfc_resolve_atrigd,
+   gfc_resolve_cotan.  We must observe this and avoid recursively creating
+   layers of nested EXPR_OP expressions.  */
+
+static bool
+is_trig_resolved (gfc_expr *f)
+{
+  /* We know we've already resolved the function if we see the lib call
+     starting with '__'.  */
+  return (f->value.function.name != NULL
+	  && strncmp ("__", f->value.function.name, 2) == 0);
+}
+
+/* Return a shallow copy of the function expression f.  The original expression
+   has its pointers cleared so that it may be freed without affecting the
+   shallow copy.  This is similar to gfc_copy_expr, but doesn't perform a deep
+   copy of the argument list, allowing it to be reused somewhere else,
+   setting the expression up nicely for gfc_replace_expr.  */
+
+static gfc_expr *
+copy_replace_function_shallow (gfc_expr *f)
+{
+  gfc_expr *fcopy;
+  gfc_actual_arglist *args;
+
+  /* The only thing deep-copied in gfc_copy_expr is args.  */
+  args = f->value.function.actual;
+  f->value.function.actual = NULL;
+  fcopy = gfc_copy_expr (f);
+  fcopy->value.function.actual = args;
+
+  /* Clear the old function so the shallow copy is not affected if the old
+     expression is freed.  */
+  f->value.function.name = NULL;
+  f->value.function.isym = NULL;
+  f->value.function.actual = NULL;
+  f->value.function.esym = NULL;
+  f->shape = NULL;
+  f->ref = NULL;
+
+  return fcopy;
+}
+
+
+/* Resolve cotan = cos / sin.  */
+
+void
+gfc_resolve_cotan (gfc_expr *f, gfc_expr *x)
+{
+  gfc_expr *result, *fcopy, *sin;
+  gfc_actual_arglist *sin_args;
+
+  if (is_trig_resolved (f))
+    return;
+
+  /* Compute cotan (x) = cos (x) / sin (x).  */
+  f->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_COS);
+  gfc_resolve_cos (f, x);
+
+  sin_args = gfc_get_actual_arglist ();
+  sin_args->expr = gfc_copy_expr (x);
+
+  sin = gfc_get_expr ();
+  sin->ts = f->ts;
+  sin->where = f->where;
+  sin->expr_type = EXPR_FUNCTION;
+  sin->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_SIN);
+  sin->value.function.actual = sin_args;
+  gfc_resolve_sin (sin, sin_args->expr);
+
+  /* Replace f with cos/sin - we do this in place in f for the caller.  */
+  fcopy = copy_replace_function_shallow (f);
+  result = gfc_divide (fcopy, sin);
+  gfc_replace_expr (f, result);
+}
+
+
 void
 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 {
@@ -964,15 +1056,19 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
     gfc_add_vptr_component (a);
   else if (a->ts.type == BT_DERIVED)
     {
+      locus where;
+
       vtab = gfc_find_derived_vtab (a->ts.u.derived);
       /* Clear the old expr.  */
       gfc_free_ref_list (a->ref);
+      where = a->where;
       memset (a, '\0', sizeof (gfc_expr));
       /* Construct a new one.  */
       a->expr_type = EXPR_VARIABLE;
       st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
       a->symtree = st;
       a->ts = vtab->ts;
+      a->where = where;
     }
 
   /* Replace the second argument with the corresponding vtab.  */
@@ -980,8 +1076,11 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
     gfc_add_vptr_component (mo);
   else if (mo->ts.type == BT_DERIVED)
     {
+      locus where;
+
       vtab = gfc_find_derived_vtab (mo->ts.u.derived);
       /* Clear the old expr.  */
+      where = mo->where;
       gfc_free_ref_list (mo->ref);
       memset (mo, '\0', sizeof (gfc_expr));
       /* Construct a new one.  */
@@ -989,6 +1088,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
       st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
       mo->symtree = st;
       mo->ts = vtab->ts;
+      mo->where = where;
     }
 
   f->ts.type = BT_LOGICAL;
@@ -2516,7 +2616,7 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
       gfc_convert_type (u, &ts, 2);
     }
 
-  f->value.function.name = gfc_get_string (PREFIX ("ftell2"));
+  f->value.function.name = gfc_get_string (PREFIX ("ftell"));
 }
 
 
@@ -2578,6 +2678,190 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
 }
 
 
+/* Build an expression for converting degrees to radians.  */
+
+static gfc_expr *
+get_radians (gfc_expr *deg)
+{
+  gfc_expr *result, *factor;
+  gfc_actual_arglist *mod_args;
+
+  gcc_assert (deg->ts.type == BT_REAL);
+
+  /* Set deg = deg % 360 to avoid offsets from large angles.  */
+  factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, &deg->where);
+  mpfr_set_d (factor->value.real, 360.0, GFC_RND_MODE);
+
+  mod_args = gfc_get_actual_arglist ();
+  mod_args->expr = deg;
+  mod_args->next = gfc_get_actual_arglist ();
+  mod_args->next->expr = factor;
+
+  result = gfc_get_expr ();
+  result->ts = deg->ts;
+  result->where = deg->where;
+  result->expr_type = EXPR_FUNCTION;
+  result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
+  result->value.function.actual = mod_args;
+
+  /* Set factor = pi / 180.  */
+  factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, &deg->where);
+  mpfr_const_pi (factor->value.real, GFC_RND_MODE);
+  mpfr_div_ui (factor->value.real, factor->value.real, 180, GFC_RND_MODE);
+
+  /* Result is rad = (deg % 360) * (pi / 180).  */
+  result = gfc_multiply (result, factor);
+  return result;
+}
+
+
+/* Build an expression for converting radians to degrees.  */
+
+static gfc_expr *
+get_degrees (gfc_expr *rad)
+{
+  gfc_expr *result, *factor;
+  gfc_actual_arglist *mod_args;
+  mpfr_t tmp;
+
+  gcc_assert (rad->ts.type == BT_REAL);
+
+  /* Set rad = rad % 2pi to avoid offsets from large angles.  */
+  factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
+  mpfr_const_pi (factor->value.real, GFC_RND_MODE);
+  mpfr_mul_ui (factor->value.real, factor->value.real, 2, GFC_RND_MODE);
+
+  mod_args = gfc_get_actual_arglist ();
+  mod_args->expr = rad;
+  mod_args->next = gfc_get_actual_arglist ();
+  mod_args->next->expr = factor;
+
+  result = gfc_get_expr ();
+  result->ts = rad->ts;
+  result->where = rad->where;
+  result->expr_type = EXPR_FUNCTION;
+  result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
+  result->value.function.actual = mod_args;
+
+  /* Set factor = 180 / pi.  */
+  factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
+  mpfr_set_ui (factor->value.real, 180, GFC_RND_MODE);
+  mpfr_init (tmp);
+  mpfr_const_pi (tmp, GFC_RND_MODE);
+  mpfr_div (factor->value.real, factor->value.real, tmp, GFC_RND_MODE);
+  mpfr_clear (tmp);
+
+  /* Result is deg = (rad % 2pi) * (180 / pi).  */
+  result = gfc_multiply (result, factor);
+  return result;
+}
+
+
+/* Resolve a call to a trig function.  */
+
+static void
+resolve_trig_call (gfc_expr *f, gfc_expr *x)
+{
+  switch (f->value.function.isym->id)
+    {
+    case GFC_ISYM_ACOS:
+      return gfc_resolve_acos (f, x);
+    case GFC_ISYM_ASIN:
+      return gfc_resolve_asin (f, x);
+    case GFC_ISYM_ATAN:
+      return gfc_resolve_atan (f, x);
+    case GFC_ISYM_ATAN2:
+      /* NB. arg3 is unused for atan2 */
+      return gfc_resolve_atan2 (f, x, NULL);
+    case GFC_ISYM_COS:
+      return gfc_resolve_cos (f, x);
+    case GFC_ISYM_COTAN:
+      return gfc_resolve_cotan (f, x);
+    case GFC_ISYM_SIN:
+      return gfc_resolve_sin (f, x);
+    case GFC_ISYM_TAN:
+      return gfc_resolve_tan (f, x);
+    default:
+      gcc_unreachable ();
+    }
+}
+
+/* Resolve degree trig function as trigd (x) = trig (radians (x)).  */
+
+void
+gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
+{
+  if (is_trig_resolved (f))
+    return;
+
+  x = get_radians (x);
+  f->value.function.actual->expr = x;
+
+  resolve_trig_call (f, x);
+}
+
+
+/* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)).  */
+
+void
+gfc_resolve_atrigd (gfc_expr *f, gfc_expr *x)
+{
+  gfc_expr *result, *fcopy;
+
+  if (is_trig_resolved (f))
+    return;
+
+  resolve_trig_call (f, x);
+
+  fcopy = copy_replace_function_shallow (f);
+  result = get_degrees (fcopy);
+  gfc_replace_expr (f, result);
+}
+
+
+/* Resolve atan2d(x) = degrees(atan2(x)).  */
+
+void
+gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
+{
+  /* Note that we lose the second arg here - that's okay because it is
+     unused in gfc_resolve_atan2 anyway.  */
+  gfc_resolve_atrigd (f, x);
+}
+
+
+/* Resolve failed_images (team, kind).  */
+
+void
+gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
+			   gfc_expr *kind)
+{
+  static char failed_images[] = "_gfortran_caf_failed_images";
+  f->rank = 1;
+  f->ts.type = BT_INTEGER;
+  if (kind == NULL)
+    f->ts.kind = gfc_default_integer_kind;
+  else
+    gfc_extract_int (kind, &f->ts.kind);
+  f->value.function.name = failed_images;
+}
+
+
+/* Resolve image_status (image, team).  */
+
+void
+gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
+			  gfc_expr *team ATTRIBUTE_UNUSED)
+{
+  static char image_status[] = "_gfortran_caf_image_status";
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = image_status;
+}
+
+
+/* Resolve image_index (...).  */
+
 void
 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
 			 gfc_expr *sub ATTRIBUTE_UNUSED)
@@ -2589,6 +2873,23 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
 }
 
 
+/* Resolve stopped_images (team, kind).  */
+
+void
+gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
+			    gfc_expr *kind)
+{
+  static char stopped_images[] = "_gfortran_caf_stopped_images";
+  f->rank = 1;
+  f->ts.type = BT_INTEGER;
+  if (kind == NULL)
+    f->ts.kind = gfc_default_integer_kind;
+  else
+    gfc_extract_int (kind, &f->ts.kind);
+  f->value.function.name = stopped_images;
+}
+
+
 void
 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
 			gfc_expr *distance ATTRIBUTE_UNUSED)