gcc/fortran/iresolve.cc

/* Intrinsic function resolution.
   Copyright (C) 2000-2022 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
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */


/* Assign name and types to intrinsic procedures.  For functions, the
   first argument to a resolution function is an expression pointer to
   the original function node and the rest are pointers to the
   arguments of the function call.  For subroutines, a pointer to the
   code node is passed.  The result type and library subroutine name
   are generally set according to the function arguments.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "gfortran.h"
#include "stringpool.h"
#include "intrinsic.h"
#include "constructor.h"
#include "arith.h"
#include "trans.h"

/* Given printf-like arguments, return a stable version of the result string.

   We already have a working, optimized string hashing table in the form of
   the identifier table.  Reusing this table is likely not to be wasted,
   since if the function name makes it to the gimple output of the frontend,
   we'll have to create the identifier anyway.  */

const char *
gfc_get_string (const char *format, ...)
{
  /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol".  */
  char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1];
  const char *str;
  va_list ap;
  tree ident;

  /* 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
    {
      int ret;
      va_start (ap, format);
      ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
      va_end (ap);
      if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation.  */
	gfc_internal_error ("identifier overflow: %d", ret);
      temp_name[sizeof (temp_name) - 1] = 0;
      str = temp_name;
    }

  ident = get_identifier (str);
  return IDENTIFIER_POINTER (ident);
}

/* MERGE and SPREAD need to have source charlen's present for passing
   to the result expression.  */
static void
check_charlen_present (gfc_expr *source)
{
  if (source->ts.u.cl == NULL)
    source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);

  if (source->expr_type == EXPR_CONSTANT)
    {
      source->ts.u.cl->length
		= gfc_get_int_expr (gfc_charlen_int_kind, NULL,
				    source->value.character.length);
      source->rank = 0;
    }
  else if (source->expr_type == EXPR_ARRAY)
    {
      gfc_constructor *c = gfc_constructor_first (source->value.constructor);
      source->ts.u.cl->length
		= gfc_get_int_expr (gfc_charlen_int_kind, NULL,
				    c->expr->value.character.length);
    }
}

/* Helper function for resolving the "mask" argument.  */

static void
resolve_mask_arg (gfc_expr *mask)
{

  gfc_typespec ts;
  gfc_clear_ts (&ts);

  if (mask->rank == 0)
    {
      /* For the scalar case, coerce the mask to kind=4 unconditionally
	 (because this is the only kind we have a library function
	 for).  */

      if (mask->ts.kind != 4)
	{
	  ts.type = BT_LOGICAL;
	  ts.kind = 4;
	  gfc_convert_type (mask, &ts, 2);
	}
    }
  else
    {
      /* In the library, we access the mask with a GFC_LOGICAL_1
	 argument.  No need to waste memory if we are about to create
	 a temporary array.  */
      if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
	{
	  ts.type = BT_LOGICAL;
	  ts.kind = 1;
	  gfc_convert_type_warn (mask, &ts, 2, 0);
	}
    }
}


static void
resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
	       const char *name, bool coarray)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;

  if (dim == NULL)
    {
      f->rank = 1;
      if (array->rank != -1)
	{
	  f->shape = gfc_get_shape (1);
	  mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
						: array->rank);
	}
    }

  f->value.function.name = gfc_get_string ("%s", name);
}


static void
resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
			  gfc_expr *dim, gfc_expr *mask)
{
  const char *prefix;

  f->ts = array->ts;

  if (mask)
    {
      if (mask->rank == 0)
	prefix = "s";
      else
	prefix = "m";

      resolve_mask_arg (mask);
    }
  else
    prefix = "";

  if (dim != NULL)
    {
      f->rank = array->rank - 1;
      f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
      gfc_resolve_dim_arg (dim);
    }

  f->value.function.name
    = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
		      gfc_type_letter (array->ts.type),
		      gfc_type_abi_kind (&array->ts));
}


/********************** Resolution functions **********************/


void
gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
{
  f->ts = a->ts;
  if (f->ts.type == BT_COMPLEX)
    f->ts.type = BT_REAL;

  f->value.function.name
    = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
		    gfc_expr *mode ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  f->value.function.name = PREFIX ("access_func");
}


void
gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
{
  f->ts.type = BT_CHARACTER;
  f->ts.kind = string->ts.kind;
  if (string->ts.u.cl)
    f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);

  f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
}


void
gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
{
  f->ts.type = BT_CHARACTER;
  f->ts.kind = string->ts.kind;
  if (string->ts.u.cl)
    f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);

  f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
}


static void
gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
			bool is_achar)
{
  f->ts.type = BT_CHARACTER;
  f->ts.kind = (kind == NULL)
	     ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
  f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
  f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);

  f->value.function.name
    = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
		      gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
{
  gfc_resolve_char_achar (f, x, kind, true);
}


void
gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
{
  f->ts.type = BT_REAL;
  f->ts.kind = x->ts.kind;
  f->value.function.name
    = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
  f->ts.type = i->ts.type;
  f->ts.kind = gfc_kind_max (i, j);

  if (i->ts.kind != j->ts.kind)
    {
      if (i->ts.kind == gfc_kind_max (i, j))
	gfc_convert_type (j, &i->ts, 2);
      else
	gfc_convert_type (i, &j->ts, 2);
    }

  f->value.function.name
    = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type),
		      gfc_type_abi_kind (&f->ts));
}


void
gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts.type = a->ts.type;
  f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);

  if (a->ts.kind != f->ts.kind)
    {
      ts.type = f->ts.type;
      ts.kind = f->ts.kind;
      gfc_convert_type (a, &ts, 2);
    }
  /* The resolved name is only used for specific intrinsics where
     the return kind is the same as the arg kind.  */
  f->value.function.name
    = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
{
  gfc_resolve_aint (f, a, NULL);
}


void
gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
  f->ts = mask->ts;

  if (dim != NULL)
    {
      gfc_resolve_dim_arg (dim);
      f->rank = mask->rank - 1;
      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
    }

  f->value.function.name
    = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
		      gfc_type_abi_kind (&mask->ts));
}


void
gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts.type = a->ts.type;
  f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);

  if (a->ts.kind != f->ts.kind)
    {
      ts.type = f->ts.type;
      ts.kind = f->ts.kind;
      gfc_convert_type (a, &ts, 2);
    }

  /* The resolved name is only used for specific intrinsics where
     the return kind is the same as the arg kind.  */
  f->value.function.name
    = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
{
  gfc_resolve_anint (f, a, NULL);
}


void
gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
{
  f->ts = mask->ts;

  if (dim != NULL)
    {
      gfc_resolve_dim_arg (dim);
      f->rank = mask->rank - 1;
      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
    }

  f->value.function.name
    = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
		      gfc_type_abi_kind (&mask->ts));
}


void
gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}

void
gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}

void
gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}

void
gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}

void
gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


/* Resolve the BESYN and BESJN intrinsics.  */

void
gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts = x->ts;
  if (n->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      gfc_convert_type (n, &ts, 2);
    }
  f->value.function.name = gfc_get_string ("<intrinsic>");
}


void
gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts = x->ts;
  f->rank = 1;
  if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
    {
      f->shape = gfc_get_shape (1);
      mpz_init (f->shape[0]);
      mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
      mpz_add_ui (f->shape[0], f->shape[0], 1);
    }

  if (n1->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      gfc_convert_type (n1, &ts, 2);
    }

  if (n2->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      gfc_convert_type (n2, &ts, 2);
    }

  if (f->value.function.isym->id == GFC_ISYM_JN2)
    f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
					     gfc_type_abi_kind (&f->ts));
  else
    f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
					     gfc_type_abi_kind (&f->ts));
}


void
gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
{
  f->ts.type = BT_LOGICAL;
  f->ts.kind = gfc_default_logical_kind;
  f->value.function.name
    = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
}


void
gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
{
  f->ts = f->value.function.isym->ts;
}


void
gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
{
  f->ts = f->value.function.isym->ts;
}


void
gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = (kind == NULL)
	     ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
  f->value.function.name
    = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  gfc_resolve_char_achar (f, a, kind, false);
}


void
gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
}


void
gfc_resolve_chdir_sub (gfc_code *c)
{
  const char *name;
  int kind;

  if (c->ext.actual->next->expr != NULL)
    kind = c->ext.actual->next->expr->ts.kind;
  else
    kind = gfc_default_integer_kind;

  name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
		   gfc_expr *mode ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  f->value.function.name = PREFIX ("chmod_func");
}


void
gfc_resolve_chmod_sub (gfc_code *c)
{
  const char *name;
  int kind;

  if (c->ext.actual->next->next->expr != NULL)
    kind = c->ext.actual->next->next->expr->ts.kind;
  else
    kind = gfc_default_integer_kind;

  name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
  f->ts.type = BT_COMPLEX;
  f->ts.kind = (kind == NULL)
	     ? gfc_default_real_kind : mpz_get_si (kind->value.integer);

  if (y == NULL)
    f->value.function.name
      = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
			gfc_type_letter (x->ts.type),
			gfc_type_abi_kind (&x->ts));
  else
    f->value.function.name
      = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
			gfc_type_letter (x->ts.type),
			gfc_type_abi_kind (&x->ts),
			gfc_type_letter (y->ts.type),
			gfc_type_abi_kind (&y->ts));
}


void
gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
  gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
						gfc_default_double_kind));
}


void
gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
  int kind;

  if (x->ts.type == BT_INTEGER)
    {
      if (y->ts.type == BT_INTEGER)
	kind = gfc_default_real_kind;
      else
	kind = y->ts.kind;
    }
  else
    {
      if (y->ts.type == BT_REAL)
	kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
      else
	kind = x->ts.kind;
    }

  f->ts.type = BT_COMPLEX;
  f->ts.kind = kind;
  f->value.function.name
    = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
		      gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts),
		      gfc_type_letter (y->ts.type),
		      gfc_type_abi_kind (&y->ts));
}


void
gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
}


void
gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;

  if (dim != NULL)
    {
      f->rank = mask->rank - 1;
      gfc_resolve_dim_arg (dim);
      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
    }

  resolve_mask_arg (mask);

  f->value.function.name
    = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f->ts),
		      gfc_type_letter (mask->ts.type));
}


void
gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
		    gfc_expr *dim)
{
  int n, m;

  if (array->ts.type == BT_CHARACTER && array->ref)
    gfc_resolve_substring_charlen (array);

  f->ts = array->ts;
  f->rank = array->rank;
  f->shape = gfc_copy_shape (array->shape, array->rank);

  if (shift->rank > 0)
    n = 1;
  else
    n = 0;

  /* If dim kind is greater than default integer we need to use the larger.  */
  m = gfc_default_integer_kind;
  if (dim != NULL)
    m = m < dim->ts.kind ? dim->ts.kind : m;

  /* Convert shift to at least m, so we don't need
      kind=1 and kind=2 versions of the library functions.  */
  if (shift->ts.kind < m)
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);
      ts.type = BT_INTEGER;
      ts.kind = m;
      gfc_convert_type_warn (shift, &ts, 2, 0);
    }

  if (dim != NULL)
    {
      if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
	  && dim->symtree->n.sym->attr.optional)
	{
	  /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
	  dim->representation.length = shift->ts.kind;
	}
      else
	{
	  gfc_resolve_dim_arg (dim);
	  /* Convert dim to shift's kind to reduce variations.  */
	  if (dim->ts.kind != shift->ts.kind)
	    gfc_convert_type_warn (dim, &shift->ts, 2, 0);
        }
    }

  if (array->ts.type == BT_CHARACTER)
    {
      if (array->ts.kind == gfc_default_character_kind)
	f->value.function.name
	  = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
      else
	f->value.function.name
	  = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
			    array->ts.kind);
    }
  else
    f->value.function.name
	= gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
}


void
gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts.type = BT_CHARACTER;
  f->ts.kind = gfc_default_character_kind;

  /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
  if (time->ts.kind != 8)
    {
      ts.type = BT_INTEGER;
      ts.kind = 8;
      ts.u.derived = NULL;
      ts.u.cl = NULL;
      gfc_convert_type (time, &ts, 2);
    }

  f->value.function.name = gfc_get_string (PREFIX ("ctime"));
}


void
gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
{
  f->ts.type = BT_REAL;
  f->ts.kind = gfc_default_double_kind;
  f->value.function.name
    = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
  f->ts.type = a->ts.type;
  if (p != NULL)
    f->ts.kind = gfc_kind_max (a,p);
  else
    f->ts.kind = a->ts.kind;

  if (p != NULL && a->ts.kind != p->ts.kind)
    {
      if (a->ts.kind == gfc_kind_max (a,p))
	gfc_convert_type (p, &a->ts, 2);
      else
	gfc_convert_type (a, &p->ts, 2);
    }

  f->value.function.name
    = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type),
		      gfc_type_abi_kind (&f->ts));
}


void
gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
  gfc_expr temp;

  temp.expr_type = EXPR_OP;
  gfc_clear_ts (&temp.ts);
  temp.value.op.op = INTRINSIC_NONE;
  temp.value.op.op1 = a;
  temp.value.op.op2 = b;
  gfc_type_convert_binary (&temp, 1);
  f->ts = temp.ts;
  f->value.function.name
    = gfc_get_string (PREFIX ("dot_product_%c%d"),
		      gfc_type_letter (f->ts.type),
		      gfc_type_abi_kind (&f->ts));
}


void
gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
		   gfc_expr *b ATTRIBUTE_UNUSED)
{
  f->ts.kind = gfc_default_double_kind;
  f->ts.type = BT_REAL;
  f->value.function.name = gfc_get_string ("__dprod_r%d",
					   gfc_type_abi_kind (&f->ts));
}


void
gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
		    gfc_expr *shift ATTRIBUTE_UNUSED)
{
  f->ts = i->ts;
  if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
    f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
  else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
    f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
  else
    gcc_unreachable ();
}


void
gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
		     gfc_expr *boundary, gfc_expr *dim)
{
  int n, m;

  if (array->ts.type == BT_CHARACTER && array->ref)
    gfc_resolve_substring_charlen (array);

  f->ts = array->ts;
  f->rank = array->rank;
  f->shape = gfc_copy_shape (array->shape, array->rank);

  n = 0;
  if (shift->rank > 0)
    n = n | 1;
  if (boundary && boundary->rank > 0)
    n = n | 2;

  /* If dim kind is greater than default integer we need to use the larger.  */
  m = gfc_default_integer_kind;
  if (dim != NULL)
    m = m < dim->ts.kind ? dim->ts.kind : m;

  /* Convert shift to at least m, so we don't need
      kind=1 and kind=2 versions of the library functions.  */
  if (shift->ts.kind < m)
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);
      ts.type = BT_INTEGER;
      ts.kind = m;
      gfc_convert_type_warn (shift, &ts, 2, 0);
    }

  if (dim != NULL)
    {
      if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
	  && dim->symtree->n.sym->attr.optional)
	{
	  /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
	  dim->representation.length = shift->ts.kind;
	}
      else
	{
	  gfc_resolve_dim_arg (dim);
	  /* Convert dim to shift's kind to reduce variations.  */
	  if (dim->ts.kind != shift->ts.kind)
	    gfc_convert_type_warn (dim, &shift->ts, 2, 0);
        }
    }

  if (array->ts.type == BT_CHARACTER)
    {
      if (array->ts.kind == gfc_default_character_kind)
	f->value.function.name
	  = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
      else
	f->value.function.name
	  = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
			    array->ts.kind);
    }
  else
    f->value.function.name
	= gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
}


void
gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
}


/* Resolve the EXTENDS_TYPE_OF intrinsic function.  */

void
gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
{
  gfc_symbol *vtab;
  gfc_symtree *st;

  /* Prevent double resolution.  */
  if (f->ts.type == BT_LOGICAL)
    return;

  /* Replace the first argument with the corresponding vtab.  */
  if (a->ts.type == BT_CLASS)
    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.  */
  if (mo->ts.type == BT_CLASS)
    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.  */
      mo->expr_type = EXPR_VARIABLE;
      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;
  f->ts.kind = 4;

  f->value.function.isym->formal->ts = a->ts;
  f->value.function.isym->formal->next->ts = mo->ts;

  /* Call library function.  */
  f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
}


void
gfc_resolve_fdate (gfc_expr *f)
{
  f->ts.type = BT_CHARACTER;
  f->ts.kind = gfc_default_character_kind;
  f->value.function.name = gfc_get_string (PREFIX ("fdate"));
}


void
gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = (kind == NULL)
	     ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
  f->value.function.name
    = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  if (n->ts.kind != f->ts.kind)
    gfc_convert_type (n, &f->ts, 2);
  f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
}


void
gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
}


/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */

void
gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("<intrinsic>");
}


void
gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__tgamma_%d", x->ts.kind);
}


void
gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
}


void
gfc_resolve_getgid (gfc_expr *f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX ("getgid"));
}


void
gfc_resolve_getpid (gfc_expr *f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX ("getpid"));
}


void
gfc_resolve_getuid (gfc_expr *f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX ("getuid"));
}


void
gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
}


void
gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("__hypot_r%d",
					   gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
  resolve_transformational ("iall", f, array, dim, mask);
}


void
gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
  /* If the kind of i and j are different, then g77 cross-promoted the
     kinds to the largest value.  The Fortran 95 standard requires the
     kinds to match.  */
  if (i->ts.kind != j->ts.kind)
    {
      if (i->ts.kind == gfc_kind_max (i, j))
	gfc_convert_type (j, &i->ts, 2);
      else
	gfc_convert_type (i, &j->ts, 2);
    }

  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
}


void
gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
  resolve_transformational ("iany", f, array, dim, mask);
}


void
gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
}


void
gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
		   gfc_expr *len ATTRIBUTE_UNUSED)
{
  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
}


void
gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
{
  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
}


void
gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
}


void
gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
}


void
gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
{
  gfc_resolve_nint (f, a, NULL);
}


void
gfc_resolve_ierrno (gfc_expr *f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
}


void
gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
  /* If the kind of i and j are different, then g77 cross-promoted the
     kinds to the largest value.  The Fortran 95 standard requires the
     kinds to match.  */
  if (i->ts.kind != j->ts.kind)
    {
      if (i->ts.kind == gfc_kind_max (i, j))
	gfc_convert_type (j, &i->ts, 2);
      else
	gfc_convert_type (i, &j->ts, 2);
    }

  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
}


void
gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
  /* If the kind of i and j are different, then g77 cross-promoted the
     kinds to the largest value.  The Fortran 95 standard requires the
     kinds to match.  */
  if (i->ts.kind != j->ts.kind)
    {
      if (i->ts.kind == gfc_kind_max (i, j))
	gfc_convert_type (j, &i->ts, 2);
      else
	gfc_convert_type (i, &j->ts, 2);
    }

  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
}


void
gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
			gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
			gfc_expr *kind)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;

  if (back && back->ts.kind != gfc_default_integer_kind)
    {
      ts.type = BT_LOGICAL;
      ts.kind = gfc_default_integer_kind;
      ts.u.derived = NULL;
      ts.u.cl = NULL;
      gfc_convert_type (back, &ts, 2);
    }

  f->value.function.name
    = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
}


void
gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = (kind == NULL)
	     ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
  f->value.function.name
    = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 2;
  f->value.function.name
    = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 8;
  f->value.function.name
    = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_long (gfc_expr *f, gfc_expr *a)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name
    = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
  resolve_transformational ("iparity", f, array, dim, mask);
}


void
gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts.type = BT_LOGICAL;
  f->ts.kind = gfc_default_integer_kind;
  if (u->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      ts.u.derived = NULL;
      ts.u.cl = NULL;
      gfc_convert_type (u, &ts, 2);
    }

  f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
}


void
gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_LOGICAL;
  f->ts.kind = gfc_default_logical_kind;
  f->value.function.name = gfc_get_string ("__is_contiguous");
}


void
gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
  f->ts = i->ts;
  f->value.function.name
    = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
}


void
gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
  f->ts = i->ts;
  f->value.function.name
    = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
}


void
gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
{
  f->ts = i->ts;
  f->value.function.name
    = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
}


void
gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
{
  int s_kind;

  s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;

  f->ts = i->ts;
  f->value.function.name
    = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
}


void
gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
  resolve_bound (f, array, dim, kind, "__lbound", false);
}


void
gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
  resolve_bound (f, array, dim, kind, "__lcobound", true);
}


void
gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;
  f->value.function.name
    = gfc_get_string ("__len_%d_i%d", string->ts.kind,
		      gfc_default_integer_kind);
}


void
gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
}


void
gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__lgamma_%d", x->ts.kind);
}


void
gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
		  gfc_expr *p2 ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
}


void
gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
{
  f->ts.type= BT_INTEGER;
  f->ts.kind = gfc_index_integer_kind;
  f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
}


void
gfc_resolve_log (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  f->ts.type = BT_LOGICAL;
  f->ts.kind = (kind == NULL)
	     ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
  f->rank = a->rank;

  f->value.function.name
    = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
  gfc_expr temp;

  if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
    {
      f->ts.type = BT_LOGICAL;
      f->ts.kind = gfc_default_logical_kind;
    }
  else
    {
      temp.expr_type = EXPR_OP;
      gfc_clear_ts (&temp.ts);
      temp.value.op.op = INTRINSIC_NONE;
      temp.value.op.op1 = a;
      temp.value.op.op2 = b;
      gfc_type_convert_binary (&temp, 1);
      f->ts = temp.ts;
    }

  f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;

  if (a->rank == 2 && b->rank == 2)
    {
      if (a->shape && b->shape)
	{
	  f->shape = gfc_get_shape (f->rank);
	  mpz_init_set (f->shape[0], a->shape[0]);
	  mpz_init_set (f->shape[1], b->shape[1]);
	}
    }
  else if (a->rank == 1)
    {
      if (b->shape)
	{
	  f->shape = gfc_get_shape (f->rank);
	  mpz_init_set (f->shape[0], b->shape[1]);
	}
    }
  else
    {
      /* b->rank == 1 and a->rank == 2 here, all other cases have
	 been caught in check.cc.   */
      if (a->shape)
	{
	  f->shape = gfc_get_shape (f->rank);
	  mpz_init_set (f->shape[0], a->shape[0]);
	}
    }

  f->value.function.name
    = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
		      gfc_type_abi_kind (&f->ts));
}


static void
gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
{
  gfc_actual_arglist *a;

  f->ts.type = args->expr->ts.type;
  f->ts.kind = args->expr->ts.kind;
  /* Find the largest type kind.  */
  for (a = args->next; a; a = a->next)
    {
      if (a->expr->ts.kind > f->ts.kind)
	f->ts.kind = a->expr->ts.kind;
    }

  /* Convert all parameters to the required kind.  */
  for (a = args; a; a = a->next)
    {
      if (a->expr->ts.kind != f->ts.kind)
	gfc_convert_type (a->expr, &f->ts, 2);
    }

  f->value.function.name
    = gfc_get_string (name, gfc_type_letter (f->ts.type),
		      gfc_type_abi_kind (&f->ts));
}


void
gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
{
  gfc_resolve_minmax ("__max_%c%d", f, args);
}

/* The smallest kind for which a minloc and maxloc implementation exists.  */

#define MINMAXLOC_MIN_KIND 4

void
gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
		    gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
{
  const char *name;
  int i, j, idim;
  int fkind;
  int d_num;

  f->ts.type = BT_INTEGER;

  /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
     we do a type conversion further down.  */
  if (kind)
    fkind = mpz_get_si (kind->value.integer);
  else
    fkind = gfc_default_integer_kind;

  if (fkind < MINMAXLOC_MIN_KIND)
    f->ts.kind = MINMAXLOC_MIN_KIND;
  else
    f->ts.kind = fkind;

  if (dim == NULL)
    {
      f->rank = 1;
      f->shape = gfc_get_shape (1);
      mpz_init_set_si (f->shape[0], array->rank);
    }
  else
    {
      f->rank = array->rank - 1;
      gfc_resolve_dim_arg (dim);
      if (array->shape && dim->expr_type == EXPR_CONSTANT)
	{
	  idim = (int) mpz_get_si (dim->value.integer);
	  f->shape = gfc_get_shape (f->rank);
	  for (i = 0, j = 0; i < f->rank; i++, j++)
	    {
	      if (i == (idim - 1))
		j++;
	      mpz_init_set (f->shape[i], array->shape[j]);
	    }
	}
    }

  if (mask)
    {
      if (mask->rank == 0)
	name = "smaxloc";
      else
	name = "mmaxloc";

      resolve_mask_arg (mask);
    }
  else
    name = "maxloc";

  if (dim)
    {
      if (array->ts.type != BT_CHARACTER || f->rank != 0)
	d_num = 1;
      else
	d_num = 2;
    }
  else
    d_num = 0;

  f->value.function.name
    = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
		      gfc_type_letter (array->ts.type),
		      gfc_type_abi_kind (&array->ts));

  if (kind)
    fkind = mpz_get_si (kind->value.integer);
  else
    fkind = gfc_default_integer_kind;

  if (fkind != f->ts.kind)
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);

      ts.type = BT_INTEGER;
      ts.kind = fkind;
      gfc_convert_type_warn (f, &ts, 2, 0);
    }

  if (back->ts.kind != gfc_logical_4_kind)
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);
      ts.type = BT_LOGICAL;
      ts.kind = gfc_logical_4_kind;
      gfc_convert_type_warn (back, &ts, 2, 0);
    }
}


void
gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value,
		     gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
		     gfc_expr *back)
{
  const char *name;
  int i, j, idim;
  int fkind;
  int d_num;

  /* See at the end of the function for why this is necessary.  */

  if (f->do_not_resolve_again)
    return;

  f->ts.type = BT_INTEGER;

  /* We have a single library version, which uses index_type.  */

  if (kind)
    fkind = mpz_get_si (kind->value.integer);
  else
    fkind = gfc_default_integer_kind;

  f->ts.kind = gfc_index_integer_kind;

  /* Convert value.  If array is not LOGICAL and value is, we already
     issued an error earlier.  */

  if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL)
      || array->ts.kind != value->ts.kind)
    gfc_convert_type_warn (value, &array->ts, 2, 0);

  if (dim == NULL)
    {
      f->rank = 1;
      f->shape = gfc_get_shape (1);
      mpz_init_set_si (f->shape[0], array->rank);
    }
  else
    {
      f->rank = array->rank - 1;
      gfc_resolve_dim_arg (dim);
      if (array->shape && dim->expr_type == EXPR_CONSTANT)
	{
	  idim = (int) mpz_get_si (dim->value.integer);
	  f->shape = gfc_get_shape (f->rank);
	  for (i = 0, j = 0; i < f->rank; i++, j++)
	    {
	      if (i == (idim - 1))
		j++;
	      mpz_init_set (f->shape[i], array->shape[j]);
	    }
	}
    }

  if (mask)
    {
      if (mask->rank == 0)
	name = "sfindloc";
      else
	name = "mfindloc";

      resolve_mask_arg (mask);
    }
  else
    name = "findloc";

  if (dim)
    {
      if (f->rank > 0)
	d_num = 1;
      else
	d_num = 2;
    }
  else
    d_num = 0;

  if (back->ts.kind != gfc_logical_4_kind)
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);
      ts.type = BT_LOGICAL;
      ts.kind = gfc_logical_4_kind;
      gfc_convert_type_warn (back, &ts, 2, 0);
    }

  f->value.function.name
    = gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num,
		      gfc_type_letter (array->ts.type, true),
		      gfc_type_abi_kind (&array->ts));

  /* We only have a single library function, so we need to convert
     here.  If the function is resolved from within a convert
     function generated on a previous round of resolution, endless
     recursion could occur.  Guard against that here.  */

  if (f->ts.kind != fkind)
    {
      f->do_not_resolve_again = 1;
      gfc_typespec ts;
      gfc_clear_ts (&ts);

      ts.type = BT_INTEGER;
      ts.kind = fkind;
      gfc_convert_type_warn (f, &ts, 2, 0);
    }

}

void
gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
		    gfc_expr *mask)
{
  const char *name;
  int i, j, idim;

  f->ts = array->ts;

  if (dim != NULL)
    {
      f->rank = array->rank - 1;
      gfc_resolve_dim_arg (dim);

      if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
	{
	  idim = (int) mpz_get_si (dim->value.integer);
	  f->shape = gfc_get_shape (f->rank);
	  for (i = 0, j = 0; i < f->rank; i++, j++)
	    {
	      if (i == (idim - 1))
		j++;
	      mpz_init_set (f->shape[i], array->shape[j]);
	    }
	}
    }

  if (mask)
    {
      if (mask->rank == 0)
	name = "smaxval";
      else
	name = "mmaxval";

      resolve_mask_arg (mask);
    }
  else
    name = "maxval";

  if (array->ts.type != BT_CHARACTER)
    f->value.function.name
      = gfc_get_string (PREFIX ("%s_%c%d"), name,
			gfc_type_letter (array->ts.type),
			gfc_type_abi_kind (&array->ts));
  else
    f->value.function.name
      = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
			gfc_type_letter (array->ts.type),
			gfc_type_abi_kind (&array->ts));
}


void
gfc_resolve_mclock (gfc_expr *f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = PREFIX ("mclock");
}


void
gfc_resolve_mclock8 (gfc_expr *f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 8;
  f->value.function.name = PREFIX ("mclock8");
}


void
gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
		  gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = kind ? mpz_get_si (kind->value.integer)
		    : gfc_default_integer_kind;

  if (f->value.function.isym->id == GFC_ISYM_MASKL)
    f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
  else
    f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
}


void
gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
		   gfc_expr *fsource ATTRIBUTE_UNUSED,
		   gfc_expr *mask ATTRIBUTE_UNUSED)
{
  if (tsource->ts.type == BT_CHARACTER && tsource->ref)
    gfc_resolve_substring_charlen (tsource);

  if (fsource->ts.type == BT_CHARACTER && fsource->ref)
    gfc_resolve_substring_charlen (fsource);

  if (tsource->ts.type == BT_CHARACTER)
    check_charlen_present (tsource);

  f->ts = tsource->ts;
  f->value.function.name
    = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
		      gfc_type_abi_kind (&tsource->ts));
}


void
gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
			gfc_expr *j ATTRIBUTE_UNUSED,
			gfc_expr *mask ATTRIBUTE_UNUSED)
{
  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
}


void
gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
{
  gfc_resolve_minmax ("__min_%c%d", f, args);
}


void
gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
		    gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
{
  const char *name;
  int i, j, idim;
  int fkind;
  int d_num;

  f->ts.type = BT_INTEGER;

  /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
     we do a type conversion further down.  */
  if (kind)
    fkind = mpz_get_si (kind->value.integer);
  else
    fkind = gfc_default_integer_kind;

  if (fkind < MINMAXLOC_MIN_KIND)
    f->ts.kind = MINMAXLOC_MIN_KIND;
  else
    f->ts.kind = fkind;

  if (dim == NULL)
    {
      f->rank = 1;
      f->shape = gfc_get_shape (1);
      mpz_init_set_si (f->shape[0], array->rank);
    }
  else
    {
      f->rank = array->rank - 1;
      gfc_resolve_dim_arg (dim);
      if (array->shape && dim->expr_type == EXPR_CONSTANT)
	{
	  idim = (int) mpz_get_si (dim->value.integer);
	  f->shape = gfc_get_shape (f->rank);
	  for (i = 0, j = 0; i < f->rank; i++, j++)
	    {
	      if (i == (idim - 1))
		j++;
	      mpz_init_set (f->shape[i], array->shape[j]);
	    }
	}
    }

  if (mask)
    {
      if (mask->rank == 0)
	name = "sminloc";
      else
	name = "mminloc";

      resolve_mask_arg (mask);
    }
  else
    name = "minloc";

  if (dim)
    {
      if (array->ts.type != BT_CHARACTER || f->rank != 0)
	d_num = 1;
      else
	d_num = 2;
    }
  else
    d_num = 0;

  f->value.function.name
    = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
		      gfc_type_letter (array->ts.type),
		      gfc_type_abi_kind (&array->ts));

  if (fkind != f->ts.kind)
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);

      ts.type = BT_INTEGER;
      ts.kind = fkind;
      gfc_convert_type_warn (f, &ts, 2, 0);
    }

  if (back->ts.kind != gfc_logical_4_kind)
    {
      gfc_typespec ts;
      gfc_clear_ts (&ts);
      ts.type = BT_LOGICAL;
      ts.kind = gfc_logical_4_kind;
      gfc_convert_type_warn (back, &ts, 2, 0);
    }
}


void
gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
		    gfc_expr *mask)
{
  const char *name;
  int i, j, idim;

  f->ts = array->ts;

  if (dim != NULL)
    {
      f->rank = array->rank - 1;
      gfc_resolve_dim_arg (dim);

      if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
	{
	  idim = (int) mpz_get_si (dim->value.integer);
	  f->shape = gfc_get_shape (f->rank);
	  for (i = 0, j = 0; i < f->rank; i++, j++)
	    {
	      if (i == (idim - 1))
		j++;
	      mpz_init_set (f->shape[i], array->shape[j]);
	    }
	}
    }

  if (mask)
    {
      if (mask->rank == 0)
	name = "sminval";
      else
	name = "mminval";

      resolve_mask_arg (mask);
    }
  else
    name = "minval";

  if (array->ts.type != BT_CHARACTER)
    f->value.function.name
      = gfc_get_string (PREFIX ("%s_%c%d"), name,
			gfc_type_letter (array->ts.type),
			gfc_type_abi_kind (&array->ts));
  else
    f->value.function.name
      = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
			gfc_type_letter (array->ts.type),
			gfc_type_abi_kind (&array->ts));
}


void
gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
  f->ts.type = a->ts.type;
  if (p != NULL)
    f->ts.kind = gfc_kind_max (a,p);
  else
    f->ts.kind = a->ts.kind;

  if (p != NULL && a->ts.kind != p->ts.kind)
    {
      if (a->ts.kind == gfc_kind_max (a,p))
	gfc_convert_type (p, &a->ts, 2);
      else
	gfc_convert_type (a, &p->ts, 2);
    }

  f->value.function.name
    = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type),
		      gfc_type_abi_kind (&f->ts));
}


void
gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
  f->ts.type = a->ts.type;
  if (p != NULL)
    f->ts.kind = gfc_kind_max (a,p);
  else
    f->ts.kind = a->ts.kind;

  if (p != NULL && a->ts.kind != p->ts.kind)
    {
      if (a->ts.kind == gfc_kind_max (a,p))
	gfc_convert_type (p, &a->ts, 2);
      else
	gfc_convert_type (a, &p->ts, 2);
    }

  f->value.function.name
    = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
		      gfc_type_abi_kind (&f->ts));
}

void
gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
{
  if (p->ts.kind != a->ts.kind)
    gfc_convert_type (p, &a->ts, 2);

  f->ts = a->ts;
  f->value.function.name
    = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}

void
gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = (kind == NULL)
	     ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
  f->value.function.name
    = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
}


void
gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
  resolve_transformational ("norm2", f, array, dim, NULL);
}


void
gfc_resolve_not (gfc_expr *f, gfc_expr *i)
{
  f->ts = i->ts;
  f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
}


void
gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
{
  f->ts.type = i->ts.type;
  f->ts.kind = gfc_kind_max (i, j);

  if (i->ts.kind != j->ts.kind)
    {
      if (i->ts.kind == gfc_kind_max (i, j))
	gfc_convert_type (j, &i->ts, 2);
      else
	gfc_convert_type (i, &j->ts, 2);
    }

  f->value.function.name
    = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type),
		      gfc_type_abi_kind (&f->ts));
}


void
gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
		  gfc_expr *vector ATTRIBUTE_UNUSED)
{
  if (array->ts.type == BT_CHARACTER && array->ref)
    gfc_resolve_substring_charlen (array);

  f->ts = array->ts;
  f->rank = 1;

  resolve_mask_arg (mask);

  if (mask->rank != 0)
    {
      if (array->ts.type == BT_CHARACTER)
	f->value.function.name
	  = array->ts.kind == 1 ? PREFIX ("pack_char")
				: gfc_get_string
					(PREFIX ("pack_char%d"),
					 array->ts.kind);
      else
	f->value.function.name = PREFIX ("pack");
    }
  else
    {
      if (array->ts.type == BT_CHARACTER)
	f->value.function.name
	  = array->ts.kind == 1 ? PREFIX ("pack_s_char")
				: gfc_get_string
					(PREFIX ("pack_s_char%d"),
					 array->ts.kind);
      else
	f->value.function.name = PREFIX ("pack_s");
    }
}


void
gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
{
  resolve_transformational ("parity", f, array, dim, NULL);
}


void
gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
		     gfc_expr *mask)
{
  resolve_transformational ("product", f, array, dim, mask);
}


void
gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string ("__rank");
}


void
gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
  f->ts.type = BT_REAL;

  if (kind != NULL)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = (a->ts.type == BT_COMPLEX)
	       ? a->ts.kind : gfc_default_real_kind;

  f->value.function.name
    = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
{
  f->ts.type = BT_REAL;
  f->ts.kind = a->ts.kind;
  f->value.function.name
    = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
		      gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
		    gfc_expr *p2 ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
}


void
gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
		    gfc_expr *ncopies)
{
  gfc_expr *tmp;
  f->ts.type = BT_CHARACTER;
  f->ts.kind = string->ts.kind;
  f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);

  /* If possible, generate a character length.  */
  if (f->ts.u.cl == NULL)
    f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);

  tmp = NULL;
  if (string->expr_type == EXPR_CONSTANT)
    {
      tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
			      string->value.character.length);
    }
  else if (string->ts.u.cl && string->ts.u.cl->length)
    {
      tmp = gfc_copy_expr (string->ts.u.cl->length);
    }

  if (tmp)
    f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
}


void
gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
		     gfc_expr *pad ATTRIBUTE_UNUSED,
		     gfc_expr *order ATTRIBUTE_UNUSED)
{
  mpz_t rank;
  int kind;
  int i;

  if (source->ts.type == BT_CHARACTER && source->ref)
    gfc_resolve_substring_charlen (source);

  f->ts = source->ts;

  gfc_array_size (shape, &rank);
  f->rank = mpz_get_si (rank);
  mpz_clear (rank);
  switch (source->ts.type)
    {
    case BT_COMPLEX:
    case BT_REAL:
    case BT_INTEGER:
    case BT_LOGICAL:
    case BT_CHARACTER:
      kind = source->ts.kind;
      break;

    default:
      kind = 0;
      break;
    }

  switch (kind)
    {
    case 4:
    case 8:
    case 10:
    case 16:
      if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
	f->value.function.name
	  = gfc_get_string (PREFIX ("reshape_%c%d"),
			    gfc_type_letter (source->ts.type),
			    gfc_type_abi_kind (&source->ts));
      else if (source->ts.type == BT_CHARACTER)
	f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
						 kind);
      else
	f->value.function.name
	  = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
      break;

    default:
      f->value.function.name = (source->ts.type == BT_CHARACTER
				? PREFIX ("reshape_char") : PREFIX ("reshape"));
      break;
    }

  if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
    {
      gfc_constructor *c;
      f->shape = gfc_get_shape (f->rank);
      c = gfc_constructor_first (shape->value.constructor);
      for (i = 0; i < f->rank; i++)
	{
	  mpz_init_set (f->shape[i], c->expr->value.integer);
	  c = gfc_constructor_next (c);
	}
    }

  /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
     so many runtime variations.  */
  if (shape->ts.kind != gfc_index_integer_kind)
    {
      gfc_typespec ts = shape->ts;
      ts.kind = gfc_index_integer_kind;
      gfc_convert_type_warn (shape, &ts, 2, 0);
    }
  if (order && order->ts.kind != gfc_index_integer_kind)
    gfc_convert_type_warn (order, &shape->ts, 2, 0);
}


void
gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
}

void
gfc_resolve_fe_runtime_error (gfc_code *c)
{
  const char *name;
  gfc_actual_arglist *a;

  name = gfc_get_string (PREFIX ("runtime_error"));

  for (a = c->ext.actual->next; a; a = a->next)
    a->name = "%VAL";

  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
  /* We set the backend_decl here because runtime_error is a
     variadic function and we would use the wrong calling
     convention otherwise.  */
  c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
}

void
gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
}


void
gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
		  gfc_expr *set ATTRIBUTE_UNUSED,
		  gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
}


void
gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
{
  t1->ts = t0->ts;
  t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
}


void
gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
			  gfc_expr *i ATTRIBUTE_UNUSED)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
}


void
gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;

  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;

  f->rank = 1;
  if (array->rank != -1)
    {
      f->shape = gfc_get_shape (1);
      mpz_init_set_ui (f->shape[0], array->rank);
    }

  f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
}


void
gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
{
  f->ts = i->ts;
  if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
    f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
  else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
    f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
  else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
    f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
  else
    gcc_unreachable ();
}


void
gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
{
  f->ts = a->ts;
  f->value.function.name
    = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type),
		      gfc_type_abi_kind (&a->ts));
}


void
gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;

  /* handler can be either BT_INTEGER or BT_PROCEDURE  */
  if (handler->ts.type == BT_INTEGER)
    {
      if (handler->ts.kind != gfc_c_int_kind)
	gfc_convert_type (handler, &f->ts, 2);
      f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
    }
  else
    f->value.function.name = gfc_get_string (PREFIX ("signal_func"));

  if (number->ts.kind != gfc_c_int_kind)
    gfc_convert_type (number, &f->ts, 2);
}


void
gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
		  gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;
}


void
gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
		  gfc_expr *dim ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_index_integer_kind;
}


void
gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
}


void
gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
		    gfc_expr *ncopies)
{
  if (source->ts.type == BT_CHARACTER && source->ref)
    gfc_resolve_substring_charlen (source);

  if (source->ts.type == BT_CHARACTER)
    check_charlen_present (source);

  f->ts = source->ts;
  f->rank = source->rank + 1;
  if (source->rank == 0)
    {
      if (source->ts.type == BT_CHARACTER)
	f->value.function.name
	  = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
				 : gfc_get_string
					(PREFIX ("spread_char%d_scalar"),
					 source->ts.kind);
      else
	f->value.function.name = PREFIX ("spread_scalar");
    }
  else
    {
      if (source->ts.type == BT_CHARACTER)
	f->value.function.name
	  = source->ts.kind == 1 ? PREFIX ("spread_char")
				 : gfc_get_string
					(PREFIX ("spread_char%d"),
					 source->ts.kind);
      else
	f->value.function.name = PREFIX ("spread");
    }

  if (dim && gfc_is_constant_expr (dim)
      && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
    {
      int i, idim;
      idim = mpz_get_ui (dim->value.integer);
      f->shape = gfc_get_shape (f->rank);
      for (i = 0; i < (idim - 1); i++)
	mpz_init_set (f->shape[i], source->shape[i]);

      mpz_init_set (f->shape[idim - 1], ncopies->value.integer);

      for (i = idim; i < f->rank ; i++)
	mpz_init_set (f->shape[i], source->shape[i-1]);
    }


  gfc_resolve_dim_arg (dim);
  gfc_resolve_index (ncopies, 1);
}


void
gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


/* Resolve the g77 compatibility function STAT AND FSTAT.  */

void
gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
		  gfc_expr *a ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
}


void
gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
		   gfc_expr *a ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
}


void
gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  if (n->ts.kind != f->ts.kind)
    gfc_convert_type (n, &f->ts, 2);

  f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
}


void
gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  if (u->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      ts.u.derived = NULL;
      ts.u.cl = NULL;
      gfc_convert_type (u, &ts, 2);
    }

  f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
}


void
gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  f->value.function.name = gfc_get_string (PREFIX ("fget"));
}


void
gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  if (u->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      ts.u.derived = NULL;
      ts.u.cl = NULL;
      gfc_convert_type (u, &ts, 2);
    }

  f->value.function.name = gfc_get_string (PREFIX ("fputc"));
}


void
gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_c_int_kind;
  f->value.function.name = gfc_get_string (PREFIX ("fput"));
}


void
gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
{
  gfc_typespec ts;
  gfc_clear_ts (&ts);

  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_intio_kind;
  if (u->ts.kind != gfc_c_int_kind)
    {
      ts.type = BT_INTEGER;
      ts.kind = gfc_c_int_kind;
      ts.u.derived = NULL;
      ts.u.cl = NULL;
      gfc_convert_type (u, &ts, 2);
    }

  f->value.function.name = gfc_get_string (PREFIX ("ftell"));
}


void
gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
			  gfc_expr *kind)
{
  f->ts.type = BT_INTEGER;
  if (kind)
    f->ts.kind = mpz_get_si (kind->value.integer);
  else
    f->ts.kind = gfc_default_integer_kind;
}


void
gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
  resolve_transformational ("sum", f, array, dim, mask);
}


void
gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
		    gfc_expr *p2 ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
}


/* Resolve the g77 compatibility function SYSTEM.  */

void
gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX ("system"));
}


void
gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


void
gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
{
  f->ts = x->ts;
  f->value.function.name
    = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type),
		      gfc_type_abi_kind (&x->ts));
}


/* 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 get_team ().  */

void
gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
{
  static char get_team[] = "_gfortran_caf_get_team";
  f->rank = 0;
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = get_team;
}


/* Resolve image_index (...).  */

void
gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
			 gfc_expr *sub ATTRIBUTE_UNUSED)
{
  static char image_index[] = "__image_index";
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = image_index;
}


/* 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;
}


/* Resolve team_number (team).  */

void
gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
{
  static char team_number[] = "_gfortran_caf_team_number";
  f->rank = 0;
  f->ts.type = BT_INTEGER;
  f->ts.kind = gfc_default_integer_kind;
  f->value.function.name = team_number;
}


void
gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
			gfc_expr *distance ATTRIBUTE_UNUSED)
{
  static char this_image[] = "__this_image";
  if (array && gfc_is_coarray (array))
    resolve_bound (f, array, dim, NULL, "__this_image", true);
  else
    {
      f->ts.type = BT_INTEGER;
      f->ts.kind = gfc_default_integer_kind;
      f->value.function.name = this_image;
    }
}


void
gfc_resolve_time (gfc_expr *f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 4;
  f->value.function.name = gfc_get_string (PREFIX ("time_func"));
}


void
gfc_resolve_time8 (gfc_expr *f)
{
  f->ts.type = BT_INTEGER;
  f->ts.kind = 8;
  f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
}


void
gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
		      gfc_expr *mold, gfc_expr *size)
{
  /* TODO: Make this do something meaningful.  */
  static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";

  if (mold->ts.type == BT_CHARACTER
	&& !mold->ts.u.cl->length
	&& gfc_is_constant_expr (mold))
    {
      int len;
      if (mold->expr_type == EXPR_CONSTANT)
        {
	  len = mold->value.character.length;
	  mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
						    NULL, len);
	}
      else
	{
	  gfc_constructor *c = gfc_constructor_first (mold->value.constructor);