gcc/fortran/check.cc

/* Check functions
   Copyright (C) 2002-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/>.  */


/* These functions check to see if an argument list is compatible with
   a particular intrinsic function or subroutine.  Presence of
   required arguments has already been established, the argument list
   has been sorted into the right order and has NULL arguments in the
   correct places for missing optional arguments.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "options.h"
#include "gfortran.h"
#include "intrinsic.h"
#include "constructor.h"
#include "target-memory.h"


/* Reset a BOZ to a zero value.  This is used to prevent run-on errors
   from resolve.cc(resolve_function).  */

static void
reset_boz (gfc_expr *x)
{
  /* Clear boz info.  */
  x->boz.rdx = 0;
  x->boz.len = 0;
  free (x->boz.str);

  x->ts.type = BT_INTEGER;
  x->ts.kind = gfc_default_integer_kind;
  mpz_init (x->value.integer);
  mpz_set_ui (x->value.integer, 0);
}

/* A BOZ literal constant can appear in a limited number of contexts.
   gfc_invalid_boz() is a helper function to simplify error/warning
   generation.  gfortran accepts the nonstandard 'X' for 'Z', and gfortran
   allows the BOZ indicator to appear as a suffix.  If -fallow-invalid-boz
   is used, then issue a warning; otherwise issue an error.  */

bool
gfc_invalid_boz (const char *msg, locus *loc)
{
  if (flag_allow_invalid_boz)
    {
      gfc_warning (0, msg, loc);
      return false;
    }

  const char *hint = _(" [see %<-fno-allow-invalid-boz%>]");
  size_t len = strlen (msg) + strlen (hint) + 1;
  char *msg2 = (char *) alloca (len);
  strcpy (msg2, msg);
  strcat (msg2, hint);
  gfc_error (msg2, loc);
  return true;
}


/* Issue an error for an illegal BOZ argument.  */

static bool
illegal_boz_arg (gfc_expr *x)
{
  if (x->ts.type == BT_BOZ)
    {
      gfc_error ("BOZ literal constant at %L cannot be an actual argument "
		 "to %qs", &x->where, gfc_current_intrinsic);
      reset_boz (x);
      return true;
    }

  return false;
}

/* Some precedures take two arguments such that both cannot be BOZ.  */

static bool
boz_args_check(gfc_expr *i, gfc_expr *j)
{
  if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
    {
      gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
		 "literal constants", gfc_current_intrinsic, &i->where,
		 &j->where);
      reset_boz (i);
      reset_boz (j);
      return false;

    }

  return true;
}


/* Check that a BOZ is a constant.  */

static bool
is_boz_constant (gfc_expr *a)
{
  if (a->expr_type != EXPR_CONSTANT)
    {
      gfc_error ("Invalid use of BOZ literal constant at %L", &a->where);
      return false;
    }

  return true;
}


/* Convert a octal string into a binary string.  This is used in the
   fallback conversion of an octal string to a REAL.  */

static char *
oct2bin(int nbits, char *oct)
{
  const char bits[8][5] = {
    "000", "001", "010", "011", "100", "101", "110", "111"};

  char *buf, *bufp;
  int i, j, n;

  j = nbits + 1;
  if (nbits == 64) j++;

  bufp = buf = XCNEWVEC (char, j + 1);
  memset (bufp, 0, j + 1);

  n = strlen (oct);
  for (i = 0; i < n; i++, oct++)
    {
      j = *oct - 48;
      strcpy (bufp, &bits[j][0]);
      bufp += 3;
    }

  bufp = XCNEWVEC (char, nbits + 1);
  if (nbits == 64)
    strcpy (bufp, buf + 2);
  else
    strcpy (bufp, buf + 1);

  free (buf);

  return bufp;
}


/* Convert a hexidecimal string into a binary string.  This is used in the
   fallback conversion of a hexidecimal string to a REAL.  */

static char *
hex2bin(int nbits, char *hex)
{
  const char bits[16][5] = {
    "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111",
    "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"};

  char *buf, *bufp;
  int i, j, n;

  bufp = buf = XCNEWVEC (char, nbits + 1);
  memset (bufp, 0, nbits + 1);

  n = strlen (hex);
  for (i = 0; i < n; i++, hex++)
    {
      j = *hex;
      if (j > 47 && j < 58)
         j -= 48;
      else if (j > 64 && j < 71)
         j -= 55;
      else if (j > 96 && j < 103)
         j -= 87;
      else
         gcc_unreachable ();

      strcpy (bufp, &bits[j][0]);
      bufp += 4;
   }

   return buf;
}


/* Fallback conversion of a BOZ string to REAL.  */

static void
bin2real (gfc_expr *x, int kind)
{
  char buf[114], *sp;
  int b, i, ie, t, w;
  bool sgn;
  mpz_t em;

  i = gfc_validate_kind (BT_REAL, kind, false);
  t = gfc_real_kinds[i].digits - 1;

  /* Number of bits in the exponent.  */
  if (gfc_real_kinds[i].max_exponent == 16384)
    w = 15;
  else if (gfc_real_kinds[i].max_exponent == 1024)
    w = 11;
  else
    w = 8;

  if (x->boz.rdx == 16)
    sp = hex2bin (gfc_real_kinds[i].mode_precision, x->boz.str);
  else if (x->boz.rdx == 8)
    sp = oct2bin (gfc_real_kinds[i].mode_precision, x->boz.str);
  else
    sp = x->boz.str;

  /* Extract sign bit. */
  sgn = *sp != '0';

  /* Extract biased exponent. */
  memset (buf, 0, 114);
  strncpy (buf, ++sp, w);
  mpz_init (em);
  mpz_set_str (em, buf, 2);
  ie = mpz_get_si (em);

  mpfr_init2 (x->value.real, t + 1);
  x->ts.type = BT_REAL;
  x->ts.kind = kind;

  sp += w;		/* Set to first digit in significand. */
  b = (1 << w) - 1;
  if ((i == 0 && ie == b) || (i == 1 && ie == b)
      || ((i == 2 || i == 3) && ie == b))
    {
      bool zeros = true;
      if (i == 2) sp++;
      for (; *sp; sp++)
	{
	  if (*sp != '0')
	    {
	      zeros = false;
	      break;
	    }
	}

      if (zeros)
	mpfr_set_inf (x->value.real, 1);
      else
	mpfr_set_nan (x->value.real);
    }
  else
    {
      if (i == 2)
	strncpy (buf, sp, t + 1);
      else
	{
	  /* Significand with hidden bit. */
 	  buf[0] = '1';
	  strncpy (&buf[1], sp, t);
	}

      /* Convert to significand to integer. */
      mpz_set_str (em, buf, 2);
      ie -= ((1 << (w - 1)) - 1);	/* Unbiased exponent. */
      mpfr_set_z_2exp (x->value.real, em, ie - t, GFC_RND_MODE);
    }

   if (sgn) mpfr_neg (x->value.real, x->value.real, GFC_RND_MODE);

   mpz_clear (em);
}


/* Fortran 2018 treats a BOZ as simply a string of bits.  gfc_boz2real ()
   converts the string into a REAL of the appropriate kind.  The treatment
   of the sign bit is processor dependent.  */

bool
gfc_boz2real (gfc_expr *x, int kind)
{
  extern int gfc_max_integer_kind;
  gfc_typespec ts;
  int len;
  char *buf, *str;

  if (!is_boz_constant (x))
    return false;

  /* Determine the length of the required string.  */
  len = 8 * kind;
  if (x->boz.rdx == 16) len /= 4;
  if (x->boz.rdx == 8) len = len / 3 + 1;
  buf = (char *) alloca (len + 1);		/* +1 for NULL terminator.  */

  if (x->boz.len >= len)			/* Truncate if necessary.  */
    {
      str = x->boz.str + (x->boz.len - len);
      strcpy(buf, str);
    }
  else						/* Copy and pad. */
    {
      memset (buf, 48, len);
      str = buf + (len - x->boz.len);
      strcpy (str, x->boz.str);
    }

  /* Need to adjust leading bits in an octal string.  */
  if (x->boz.rdx == 8)
    {
      /* Clear first bit.  */
      if (kind == 4 || kind == 10 || kind == 16)
	{
	  if (buf[0] == '4')
	    buf[0] = '0';
	  else if (buf[0] == '5')
	    buf[0] = '1';
	  else if (buf[0] == '6')
	    buf[0] = '2';
	  else if (buf[0] == '7')
	    buf[0] = '3';
	}
      /* Clear first two bits.  */
      else
	{
	  if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6')
	    buf[0] = '0';
	  else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7')
	    buf[0] = '1';
	}
    }

  /* Reset BOZ string to the truncated or padded version.  */
  free (x->boz.str);
  x->boz.len = len;
  x->boz.str = XCNEWVEC (char, len + 1);
  strncpy (x->boz.str, buf, len);

  /* For some targets, the largest INTEGER in terms of bits is smaller than
     the bits needed to hold the REAL.  Fortunately, the kind type parameter
     indicates the number of bytes required to an INTEGER and a REAL.  */
  if (gfc_max_integer_kind < kind)
    {
      bin2real (x, kind);
    }
  else
    {
      /* Convert to widest possible integer.  */
      gfc_boz2int (x, gfc_max_integer_kind);
      ts.type = BT_REAL;
      ts.kind = kind;
      if (!gfc_convert_boz (x, &ts))
	{
	  gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where);
	  return false;
	}
    }

  return true;
}


/* Fortran 2018 treats a BOZ as simply a string of bits.  gfc_boz2int ()
   converts the string into an INTEGER of the appropriate kind.  The
   treatment of the sign bit is processor dependent.  If the  converted
   value exceeds the range of the type, then wrap-around semantics are
   applied.  */

bool
gfc_boz2int (gfc_expr *x, int kind)
{
  int i, len;
  char *buf, *str;
  mpz_t tmp1;

  if (!is_boz_constant (x))
    return false;

  i = gfc_validate_kind (BT_INTEGER, kind, false);
  len = gfc_integer_kinds[i].bit_size;
  if (x->boz.rdx == 16) len /= 4;
  if (x->boz.rdx == 8) len = len / 3 + 1;
  buf = (char *) alloca (len + 1);		/* +1 for NULL terminator.  */

  if (x->boz.len >= len)			/* Truncate if necessary.  */
    {
      str = x->boz.str + (x->boz.len - len);
      strcpy(buf, str);
    }
  else						/* Copy and pad. */
    {
      memset (buf, 48, len);
      str = buf + (len - x->boz.len);
      strcpy (str, x->boz.str);
    }

  /* Need to adjust leading bits in an octal string.  */
  if (x->boz.rdx == 8)
    {
      /* Clear first bit.  */
      if (kind == 1 || kind == 4 || kind == 16)
	{
	  if (buf[0] == '4')
	    buf[0] = '0';
	  else if (buf[0] == '5')
	    buf[0] = '1';
	  else if (buf[0] == '6')
	    buf[0] = '2';
	  else if (buf[0] == '7')
	    buf[0] = '3';
	}
      /* Clear first two bits.  */
      else
	{
	  if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6')
	    buf[0] = '0';
	  else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7')
	    buf[0] = '1';
	}
    }

  /* Convert as-if unsigned integer.  */
  mpz_init (tmp1);
  mpz_set_str (tmp1, buf, x->boz.rdx);

  /* Check for wrap-around.  */
  if (mpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0)
    {
      mpz_t tmp2;
      mpz_init (tmp2);
      mpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1);
      mpz_mod (tmp1, tmp1, tmp2);
      mpz_sub (tmp1, tmp1, tmp2);
      mpz_clear (tmp2);
    }

  /* Clear boz info.  */
  x->boz.rdx = 0;
  x->boz.len = 0;
  free (x->boz.str);

  mpz_init (x->value.integer);
  mpz_set (x->value.integer, tmp1);
  x->ts.type = BT_INTEGER;
  x->ts.kind = kind;
  mpz_clear (tmp1);

  return true;
}


/* Make sure an expression is a scalar.  */

static bool
scalar_check (gfc_expr *e, int n)
{
  if (e->rank == 0)
    return true;

  gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
	     &e->where);

  return false;
}


/* Check the type of an expression.  */

static bool
type_check (gfc_expr *e, int n, bt type)
{
  if (e->ts.type == type)
    return true;

  gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
	     &e->where, gfc_basic_typename (type));

  return false;
}


/* Check that the expression is a numeric type.  */

static bool
numeric_check (gfc_expr *e, int n)
{
  /* Users sometime use a subroutine designator as an actual argument to
     an intrinsic subprogram that expects an argument with a numeric type.  */
  if (e->symtree && e->symtree->n.sym->attr.subroutine)
    goto error;

  if (gfc_numeric_ts (&e->ts))
    return true;

  /* If the expression has not got a type, check if its namespace can
     offer a default type.  */
  if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
	&& e->symtree->n.sym->ts.type == BT_UNKNOWN
	&& gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns)
	&& gfc_numeric_ts (&e->symtree->n.sym->ts))
    {
      e->ts = e->symtree->n.sym->ts;
      return true;
    }

error:

  gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
	     &e->where);

  return false;
}


/* Check that an expression is integer or real.  */

static bool
int_or_real_check (gfc_expr *e, int n)
{
  if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
		 "or REAL", gfc_current_intrinsic_arg[n]->name,
		 gfc_current_intrinsic, &e->where);
      return false;
    }

  return true;
}

/* Check that an expression is integer or real; allow character for
   F2003 or later.  */

static bool
int_or_real_or_char_check_f2003 (gfc_expr *e, int n)
{
  if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
    {
      if (e->ts.type == BT_CHARACTER)
	return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for "
			       "%qs argument of %qs intrinsic at %L",
			       gfc_current_intrinsic_arg[n]->name,
			       gfc_current_intrinsic, &e->where);
      else
	{
	  if (gfc_option.allow_std & GFC_STD_F2003)
	    gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
		       "or REAL or CHARACTER",
		       gfc_current_intrinsic_arg[n]->name,
		       gfc_current_intrinsic, &e->where);
	  else
	    gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
		       "or REAL", gfc_current_intrinsic_arg[n]->name,
		       gfc_current_intrinsic, &e->where);
	}
      return false;
    }

  return true;
}

/* Check that an expression is an intrinsic type.  */
static bool
intrinsic_type_check (gfc_expr *e, int n)
{
  if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
      && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER
      && e->ts.type != BT_LOGICAL)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
		 gfc_current_intrinsic_arg[n]->name,
		 gfc_current_intrinsic, &e->where);
      return false;
    }
  return true;
}

/* Check that an expression is real or complex.  */

static bool
real_or_complex_check (gfc_expr *e, int n)
{
  if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
		 "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
		 gfc_current_intrinsic, &e->where);
      return false;
    }

  return true;
}


/* Check that an expression is INTEGER or PROCEDURE.  */

static bool
int_or_proc_check (gfc_expr *e, int n)
{
  if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
		 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
		 gfc_current_intrinsic, &e->where);
      return false;
    }

  return true;
}


/* Check that the expression is an optional constant integer
   and that it specifies a valid kind for that type.  */

static bool
kind_check (gfc_expr *k, int n, bt type)
{
  int kind;

  if (k == NULL)
    return true;

  if (!type_check (k, n, BT_INTEGER))
    return false;

  if (!scalar_check (k, n))
    return false;

  if (!gfc_check_init_expr (k))
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
		 &k->where);
      return false;
    }

  if (gfc_extract_int (k, &kind)
      || gfc_validate_kind (type, kind, true) < 0)
    {
      gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
		 &k->where);
      return false;
    }

  return true;
}


/* Make sure the expression is a double precision real.  */

static bool
double_check (gfc_expr *d, int n)
{
  if (!type_check (d, n, BT_REAL))
    return false;

  if (d->ts.kind != gfc_default_double_kind)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be double "
		 "precision", gfc_current_intrinsic_arg[n]->name,
		 gfc_current_intrinsic, &d->where);
      return false;
    }

  return true;
}


static bool
coarray_check (gfc_expr *e, int n)
{
  if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
	&& CLASS_DATA (e)->attr.codimension
	&& CLASS_DATA (e)->as->corank)
    {
      gfc_add_class_array_ref (e);
      return true;
    }

  if (!gfc_is_coarray (e))
    {
      gfc_error ("Expected coarray variable as %qs argument to the %s "
                 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
		 gfc_current_intrinsic, &e->where);
      return false;
    }

  return true;
}


/* Make sure the expression is a logical array.  */

static bool
logical_array_check (gfc_expr *array, int n)
{
  if (array->ts.type != BT_LOGICAL || array->rank == 0)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
		 "array", gfc_current_intrinsic_arg[n]->name,
		 gfc_current_intrinsic, &array->where);
      return false;
    }

  return true;
}


/* Make sure an expression is an array.  */

static bool
array_check (gfc_expr *e, int n)
{
  if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
	&& CLASS_DATA (e)->attr.dimension
	&& CLASS_DATA (e)->as->rank)
    {
      gfc_add_class_array_ref (e);
    }

  if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
    return true;

  gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
	     &e->where);

  return false;
}


/* If expr is a constant, then check to ensure that it is greater than
   of equal to zero.  */

static bool
nonnegative_check (const char *arg, gfc_expr *expr)
{
  int i;

  if (expr->expr_type == EXPR_CONSTANT)
    {
      gfc_extract_int (expr, &i);
      if (i < 0)
	{
	  gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
	  return false;
	}
    }

  return true;
}


/* If expr is a constant, then check to ensure that it is greater than zero.  */

static bool
positive_check (int n, gfc_expr *expr)
{
  int i;

  if (expr->expr_type == EXPR_CONSTANT)
    {
      gfc_extract_int (expr, &i);
      if (i <= 0)
	{
	  gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
		     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
		     &expr->where);
	  return false;
	}
    }

  return true;
}


/* If expr2 is constant, then check that the value is less than
   (less than or equal to, if 'or_equal' is true) bit_size(expr1).  */

static bool
less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
		    gfc_expr *expr2, bool or_equal)
{
  int i2, i3;

  if (expr2->expr_type == EXPR_CONSTANT)
    {
      gfc_extract_int (expr2, &i2);
      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);

      /* For ISHFT[C], check that |shift| <= bit_size(i).  */
      if (arg2 == NULL)
	{
	  if (i2 < 0)
	    i2 = -i2;

	  if (i2 > gfc_integer_kinds[i3].bit_size)
	    {
	      gfc_error ("The absolute value of SHIFT at %L must be less "
			 "than or equal to BIT_SIZE(%qs)",
			 &expr2->where, arg1);
	      return false;
	    }
	}

      if (or_equal)
	{
	  if (i2 > gfc_integer_kinds[i3].bit_size)
	    {
	      gfc_error ("%qs at %L must be less than "
			 "or equal to BIT_SIZE(%qs)",
			 arg2, &expr2->where, arg1);
	      return false;
	    }
	}
      else
	{
	  if (i2 >= gfc_integer_kinds[i3].bit_size)
	    {
	      gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
			 arg2, &expr2->where, arg1);
	      return false;
	    }
	}
    }

  return true;
}


/* If expr is constant, then check that the value is less than or equal
   to the bit_size of the kind k.  */

static bool
less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
{
  int i, val;

  if (expr->expr_type != EXPR_CONSTANT)
    return true;

  i = gfc_validate_kind (BT_INTEGER, k, false);
  gfc_extract_int (expr, &val);

  if (val > gfc_integer_kinds[i].bit_size)
    {
      gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
		 "INTEGER(KIND=%d)", arg, &expr->where, k);
      return false;
    }

  return true;
}


/* If expr2 and expr3 are constants, then check that the value is less than
   or equal to bit_size(expr1).  */

static bool
less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
	       gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
{
  int i2, i3;

  if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
    {
      gfc_extract_int (expr2, &i2);
      gfc_extract_int (expr3, &i3);
      i2 += i3;
      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
      if (i2 > gfc_integer_kinds[i3].bit_size)
	{
	  gfc_error ("%<%s + %s%> at %L must be less than or equal "
		     "to BIT_SIZE(%qs)",
		     arg2, arg3, &expr2->where, arg1);
	  return false;
	}
    }

  return true;
}

/* Make sure two expressions have the same type.  */

static bool
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
{
  gfc_typespec *ets = &e->ts;
  gfc_typespec *fts = &f->ts;

  if (assoc)
    {
      /* Procedure pointer component expressions have the type of the interface
	 procedure. If they are being tested for association with a procedure
	 pointer (ie. not a component), the type of the procedure must be
	 determined.  */
      if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
	ets = &e->symtree->n.sym->ts;
      if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
	fts = &f->symtree->n.sym->ts;
    }

  if (gfc_compare_types (ets, fts))
    return true;

  gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
	     "and kind as %qs", gfc_current_intrinsic_arg[m]->name,
	     gfc_current_intrinsic, &f->where,
	     gfc_current_intrinsic_arg[n]->name);

  return false;
}


/* Make sure that an expression has a certain (nonzero) rank.  */

static bool
rank_check (gfc_expr *e, int n, int rank)
{
  if (e->rank == rank)
    return true;

  gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
	     &e->where, rank);

  return false;
}


/* Make sure a variable expression is not an optional dummy argument.  */

static bool
nonoptional_check (gfc_expr *e, int n)
{
  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
		 &e->where);
    }

  /* TODO: Recursive check on nonoptional variables?  */

  return true;
}


/* Check for ALLOCATABLE attribute.  */

static bool
allocatable_check (gfc_expr *e, int n)
{
  symbol_attribute attr;

  attr = gfc_variable_attr (e, NULL);
  if (!attr.allocatable
     || (attr.associate_var && !attr.select_rank_temporary))
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
		 &e->where);
      return false;
    }

  return true;
}


/* Check that an expression has a particular kind.  */

static bool
kind_value_check (gfc_expr *e, int n, int k)
{
  if (e->ts.kind == k)
    return true;

  gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
	     &e->where, k);

  return false;
}


/* Make sure an expression is a variable.  */

static bool
variable_check (gfc_expr *e, int n, bool allow_proc)
{
  if (e->expr_type == EXPR_VARIABLE
      && e->symtree->n.sym->attr.intent == INTENT_IN
      && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
	  || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT)
      && !gfc_check_vardef_context (e, false, true, false, NULL))
    {
      gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)",
		 gfc_current_intrinsic_arg[n]->name,
		 gfc_current_intrinsic, &e->where);
      return false;
    }

  if (e->expr_type == EXPR_VARIABLE
      && e->symtree->n.sym->attr.flavor != FL_PARAMETER
      && (allow_proc || !e->symtree->n.sym->attr.function))
    return true;

  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
      && e->symtree->n.sym == e->symtree->n.sym->result)
    {
      gfc_namespace *ns;
      for (ns = gfc_current_ns; ns; ns = ns->parent)
	if (ns->proc_name == e->symtree->n.sym)
	  return true;
    }

  /* F2018:R902: function reference having a data pointer result.  */
  if (e->expr_type == EXPR_FUNCTION
      && e->symtree->n.sym->attr.flavor == FL_PROCEDURE
      && e->symtree->n.sym->attr.function
      && e->symtree->n.sym->attr.pointer)
    return true;

  gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);

  return false;
}


/* Check the common DIM parameter for correctness.  */

static bool
dim_check (gfc_expr *dim, int n, bool optional)
{
  if (dim == NULL)
    return true;

  if (!type_check (dim, n, BT_INTEGER))
    return false;

  if (!scalar_check (dim, n))
    return false;

  if (!optional && !nonoptional_check (dim, n))
    return false;

  return true;
}


/* If a coarray DIM parameter is a constant, make sure that it is greater than
   zero and less than or equal to the corank of the given array.  */

static bool
dim_corank_check (gfc_expr *dim, gfc_expr *array)
{
  int corank;

  gcc_assert (array->expr_type == EXPR_VARIABLE);

  if (dim->expr_type != EXPR_CONSTANT)
    return true;

  if (array->ts.type == BT_CLASS)
    return true;

  corank = gfc_get_corank (array);

  if (mpz_cmp_ui (dim->value.integer, 1) < 0
      || mpz_cmp_ui (dim->value.integer, corank) > 0)
    {
      gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
		 "codimension index", gfc_current_intrinsic, &dim->where);

      return false;
    }

  return true;
}


/* If a DIM parameter is a constant, make sure that it is greater than
   zero and less than or equal to the rank of the given array.  If
   allow_assumed is zero then dim must be less than the rank of the array
   for assumed size arrays.  */

static bool
dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
{
  gfc_array_ref *ar;
  int rank;

  if (dim == NULL)
    return true;

  if (dim->expr_type != EXPR_CONSTANT)
    return true;

  if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
      && array->value.function.isym->id == GFC_ISYM_SPREAD)
    rank = array->rank + 1;
  else
    rank = array->rank;

  /* Assumed-rank array.  */
  if (rank == -1)
    rank = GFC_MAX_DIMENSIONS;

  if (array->expr_type == EXPR_VARIABLE)
    {
      ar = gfc_find_array_ref (array, true);
      if (!ar)
	return false;
      if (ar->as->type == AS_ASSUMED_SIZE
	  && !allow_assumed
	  && ar->type != AR_ELEMENT
	  && ar->type != AR_SECTION)
	rank--;
    }

  if (mpz_cmp_ui (dim->value.integer, 1) < 0
      || mpz_cmp_ui (dim->value.integer, rank) > 0)
    {
      gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
		 "dimension index", gfc_current_intrinsic, &dim->where);

      return false;
    }

  return true;
}


/* Compare the size of a along dimension ai with the size of b along
   dimension bi, returning 0 if they are known not to be identical,
   and 1 if they are identical, or if this cannot be determined.  */

static int
identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
{
  mpz_t a_size, b_size;
  int ret;

  gcc_assert (a->rank > ai);
  gcc_assert (b->rank > bi);

  ret = 1;

  if (gfc_array_dimen_size (a, ai, &a_size))
    {
      if (gfc_array_dimen_size (b, bi, &b_size))
	{
	  if (mpz_cmp (a_size, b_size) != 0)
	    ret = 0;

	  mpz_clear (b_size);
	}
      mpz_clear (a_size);
    }
  return ret;
}

/*  Calculate the length of a character variable, including substrings.
    Strip away parentheses if necessary.  Return -1 if no length could
    be determined.  */

static long
gfc_var_strlen (const gfc_expr *a)
{
  gfc_ref *ra;

  while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
    a = a->value.op.op1;

  for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
    ;

  if (ra)
    {
      long start_a, end_a;

      if (!ra->u.ss.end)
	return -1;

      if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
	  && ra->u.ss.end->expr_type == EXPR_CONSTANT)
	{
	  start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
				   : 1;
	  end_a = mpz_get_si (ra->u.ss.end->value.integer);
	  return (end_a < start_a) ? 0 : end_a - start_a + 1;
	}
      else if (ra->u.ss.start
	       && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
	return 1;
      else
	return -1;
    }

  if (a->ts.u.cl && a->ts.u.cl->length
      && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    return mpz_get_si (a->ts.u.cl->length->value.integer);
  else if (a->expr_type == EXPR_CONSTANT
	   && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
    return a->value.character.length;
  else
    return -1;

}

/* Check whether two character expressions have the same length;
   returns true if they have or if the length cannot be determined,
   otherwise return false and raise a gfc_error.  */

bool
gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
{
   long len_a, len_b;

   len_a = gfc_var_strlen(a);
   len_b = gfc_var_strlen(b);

   if (len_a == -1 || len_b == -1 || len_a == len_b)
     return true;
   else
     {
       gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
		  len_a, len_b, name, &a->where);
       return false;
     }
}


/***** Check functions *****/

/* Check subroutine suitable for intrinsics taking a real argument and
   a kind argument for the result.  */

static bool
check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
{
  if (!type_check (a, 0, BT_REAL))
    return false;
  if (!kind_check (kind, 1, type))
    return false;

  return true;
}


/* Check subroutine suitable for ceiling, floor and nint.  */

bool
gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
{
  return check_a_kind (a, kind, BT_INTEGER);
}


/* Check subroutine suitable for aint, anint.  */

bool
gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
{
  return check_a_kind (a, kind, BT_REAL);
}


bool
gfc_check_abs (gfc_expr *a)
{
  if (!numeric_check (a, 0))
    return false;

  return true;
}


bool
gfc_check_achar (gfc_expr *a, gfc_expr *kind)
{
  if (a->ts.type == BT_BOZ)
    {
      if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
			   "ACHAR intrinsic subprogram"), &a->where))
	return false;

      if (!gfc_boz2int (a, gfc_default_integer_kind))
	return false;
    }

  if (!type_check (a, 0, BT_INTEGER))
    return false;

  if (!kind_check (kind, 1, BT_CHARACTER))
    return false;

  return true;
}


bool
gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
{
  if (!type_check (name, 0, BT_CHARACTER)
      || !scalar_check (name, 0))
    return false;
  if (!kind_value_check (name, 0, gfc_default_character_kind))
    return false;

  if (!type_check (mode, 1, BT_CHARACTER)
      || !scalar_check (mode, 1))
    return false;
  if (!kind_value_check (mode, 1, gfc_default_character_kind))
    return false;

  return true;
}


bool
gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
{
  if (!logical_array_check (mask, 0))
    return false;

  if (!dim_check (dim, 1, false))
    return false;

  if (!dim_rank_check (dim, mask, 0))
    return false;

  return true;
}


/* Limited checking for ALLOCATED intrinsic.  Additional checking
   is performed in intrinsic.cc(sort_actual), because ALLOCATED
   has two mutually exclusive non-optional arguments.  */

bool
gfc_check_allocated (gfc_expr *array)
{
  /* Tests on allocated components of coarrays need to detour the check to
     argument of the _caf_get.  */
  if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION
      && array->value.function.isym
      && array->value.function.isym->id == GFC_ISYM_CAF_GET)
    {
      array = array->value.function.actual->expr;
      if (!array->ref)
	return false;
    }

  if (!variable_check (array, 0, false))
    return false;
  if (!allocatable_check (array, 0))
    return false;

  return true;
}


/* Common check function where the first argument must be real or
   integer and the second argument must be the same as the first.  */

bool
gfc_check_a_p (gfc_expr *a, gfc_expr *p)
{
  if (!int_or_real_check (a, 0))
    return false;

  if (a->ts.type != p->ts.type)
    {
      gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
		 "have the same type", gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
		 &p->where);
      return false;
    }

  if (a->ts.kind != p->ts.kind)
    {
      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
			   &p->where))
       return false;
    }

  return true;
}


bool
gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
{
  if (!double_check (x, 0) || !double_check (y, 1))
    return false;

  return true;
}

bool
gfc_invalid_null_arg (gfc_expr *x)
{
  if (x->expr_type == EXPR_NULL)
    {
      gfc_error ("NULL at %L is not permitted as actual argument "
		 "to %qs intrinsic function", &x->where,
		 gfc_current_intrinsic);
      return true;
    }
  return false;
}

bool
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
{
  symbol_attribute attr1, attr2;
  int i;
  bool t;

  if (gfc_invalid_null_arg (pointer))
    return false;

  attr1 = gfc_expr_attr (pointer);

  if (!attr1.pointer && !attr1.proc_pointer)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
		 &pointer->where);
      return false;
    }

  /* F2008, C1242.  */
  if (attr1.pointer && gfc_is_coindexed (pointer))
    {
      gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
		 "coindexed", gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic, &pointer->where);
      return false;
    }

  /* Target argument is optional.  */
  if (target == NULL)
    return true;

  if (gfc_invalid_null_arg (target))
    return false;

  if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
    attr2 = gfc_expr_attr (target);
  else
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
		 "or target VARIABLE or FUNCTION",
		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
		 &target->where);
      return false;
    }

  if (attr1.pointer && !attr2.pointer && !attr2.target)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
		 "or a TARGET", gfc_current_intrinsic_arg[1]->name,
		 gfc_current_intrinsic, &target->where);
      return false;
    }

  /* F2008, C1242.  */
  if (attr1.pointer && gfc_is_coindexed (target))
    {
      gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
		 "coindexed", gfc_current_intrinsic_arg[1]->name,
		 gfc_current_intrinsic, &target->where);
      return false;
    }

  t = true;
  if (!same_type_check (pointer, 0, target, 1, true))
    t = false;
  /* F2018 C838 explicitly allows an assumed-rank variable as the first
     argument of intrinsic inquiry functions.  */
  if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank))
    t = false;
  if (target->rank > 0 && target->ref)
    {
      for (i = 0; i < target->rank; i++)
	if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
	  {
	    gfc_error ("Array section with a vector subscript at %L shall not "
		       "be the target of a pointer",
		       &target->where);
	    t = false;
	    break;
	  }
    }
  return t;
}


bool
gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
{
  /* gfc_notify_std would be a waste of time as the return value
     is seemingly used only for the generic resolution.  The error
     will be: Too many arguments.  */
  if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
    return false;

  return gfc_check_atan2 (y, x);
}


bool
gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
{
  if (!type_check (y, 0, BT_REAL))
    return false;
  if (!same_type_check (y, 0, x, 1))
    return false;

  return true;
}


static bool
gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
		  gfc_expr *stat, int stat_no)
{
  if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no))
    return false;

  if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
      && !(atom->ts.type == BT_LOGICAL
	   && atom->ts.kind == gfc_atomic_logical_kind))
    {
      gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
		 "integer of ATOMIC_INT_KIND or a logical of "
		 "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
      return false;
    }

  if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom))
    {
      gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
		 "coarray or coindexed", &atom->where, gfc_current_intrinsic);
      return false;
    }

  if (atom->ts.type != value->ts.type)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
		 "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name,
		 gfc_current_intrinsic, &value->where,
		 gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
      return false;
    }

  if (stat != NULL)
    {
      if (!type_check (stat, stat_no, BT_INTEGER))
	return false;
      if (!scalar_check (stat, stat_no))
	return false;
      if (!variable_check (stat, stat_no, false))
	return false;
      if (!kind_value_check (stat, stat_no, gfc_default_integer_kind))
	return false;

      if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
			   gfc_current_intrinsic, &stat->where))
	return false;
    }

  return true;
}


bool
gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
{
  if (atom->expr_type == EXPR_FUNCTION
      && atom->value.function.isym
      && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
    atom = atom->value.function.actual->expr;

  if (!gfc_check_vardef_context (atom, false, false, false, NULL))
    {
      gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
		 "definable", gfc_current_intrinsic, &atom->where);
      return false;
    }

  return gfc_check_atomic (atom, 0, value, 1, stat, 2);
}


bool
gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
{
  if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
    {
      gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
		 "integer of ATOMIC_INT_KIND", &atom->where,
		 gfc_current_intrinsic);
      return false;
    }

  return gfc_check_atomic_def (atom, value, stat);
}


bool
gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
{
  if (atom->expr_type == EXPR_FUNCTION
      && atom->value.function.isym
      && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
    atom = atom->value.function.actual->expr;

  if (!gfc_check_vardef_context (value, false, false, false, NULL))
    {
      gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
		 "definable", gfc_current_intrinsic, &value->where);
      return false;
    }

  return gfc_check_atomic (atom, 1, value, 0, stat, 2);
}


bool
gfc_check_image_status (gfc_expr *image, gfc_expr *team)
{
  /* IMAGE has to be a positive, scalar integer.  */
  if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0)
      || !positive_check (0, image))
    return false;

  if (team)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
		 &team->where);
      return false;
    }
  return true;
}


bool
gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
{
  if (team)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
		 &team->where);
      return false;
    }

  if (kind)
    {
      int k;

      if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1)
	  || !positive_check (1, kind))
	return false;

      /* Get the kind, reporting error on non-constant or overflow.  */
      gfc_current_locus = kind->where;
      if (gfc_extract_int (kind, &k, 1))
	return false;
      if (gfc_validate_kind (BT_INTEGER, k, true) == -1)
	{
	  gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
		     "valid integer kind", gfc_current_intrinsic_arg[1]->name,
		     gfc_current_intrinsic, &kind->where);
	  return false;
	}
    }
  return true;
}


bool
gfc_check_get_team (gfc_expr *level)
{
  if (level)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
		 &level->where);
      return false;
    }
  return true;
}


bool
gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
		      gfc_expr *new_val,  gfc_expr *stat)
{
  if (atom->expr_type == EXPR_FUNCTION
      && atom->value.function.isym
      && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
    atom = atom->value.function.actual->expr;

  if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4))
    return false;

  if (!scalar_check (old, 1) || !scalar_check (compare, 2))
    return false;

  if (!same_type_check (atom, 0, old, 1))
    return false;

  if (!same_type_check (atom, 0, compare, 2))
    return false;

  if (!gfc_check_vardef_context (atom, false, false, false, NULL))
    {
      gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
		 "definable", gfc_current_intrinsic, &atom->where);
      return false;
    }

  if (!gfc_check_vardef_context (old, false, false, false, NULL))
    {
      gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
		 "definable", gfc_current_intrinsic, &old->where);
      return false;
    }

  return true;
}

bool
gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
{
  if (event->ts.type != BT_DERIVED
      || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
      || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
    {
      gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
		 "shall be of type EVENT_TYPE", &event->where);
      return false;
    }

  if (!scalar_check (event, 0))
    return false;

  if (!gfc_check_vardef_context (count, false, false, false, NULL))
    {
      gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
		 "shall be definable", &count->where);
      return false;
    }

  if (!type_check (count, 1, BT_INTEGER))
    return false;

  int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
  int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);

  if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
    {
      gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
		 "shall have at least the range of the default integer",
		 &count->where);
      return false;
    }

  if (stat != NULL)
    {
      if (!type_check (stat, 2, BT_INTEGER))
	return false;
      if (!scalar_check (stat, 2))
	return false;
      if (!variable_check (stat, 2, false))
	return false;

      if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
			   gfc_current_intrinsic, &stat->where))
	return false;
    }

  return true;
}


bool
gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
			   gfc_expr *stat)
{
  if (atom->expr_type == EXPR_FUNCTION
      && atom->value.function.isym
      && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
    atom = atom->value.function.actual->expr;

  if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
    {
      gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
		 "integer of ATOMIC_INT_KIND", &atom->where,
		 gfc_current_intrinsic);
      return false;
    }

  if (!gfc_check_atomic (atom, 0, value, 1, stat, 3))
    return false;

  if (!scalar_check (old, 2))
    return false;

  if (!same_type_check (atom, 0, old, 2))
    return false;

  if (!gfc_check_vardef_context (atom, false, false, false, NULL))
    {
      gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
		 "definable", gfc_current_intrinsic, &atom->where);
      return false;
    }

  if (!gfc_check_vardef_context (old, false, false, false, NULL))
    {
      gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
		 "definable", gfc_current_intrinsic, &old->where);
      return false;
    }

  return true;
}


/* BESJN and BESYN functions.  */

bool
gfc_check_besn (gfc_expr *n, gfc_expr *x)
{
  if (!type_check (n, 0, BT_INTEGER))
    return false;
  if (n->expr_type == EXPR_CONSTANT)
    {
      int i;
      gfc_extract_int (n, &i);
      if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument "
				    "N at %L", &n->where))
	return false;
    }

  if (!type_check (x, 1, BT_REAL))
    return false;

  return true;
}


/* Transformational version of the Bessel JN and YN functions.  */

bool
gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
{
  if (!type_check (n1, 0, BT_INTEGER))
    return false;
  if (!scalar_check (n1, 0))
    return false;
  if (!nonnegative_check ("N1", n1))
    return false;

  if (!type_check (n2, 1, BT_INTEGER))
    return false;
  if (!scalar_check (n2, 1))
    return false;
  if (!nonnegative_check ("N2", n2))
    return false;

  if (!type_check (x, 2, BT_REAL))
    return false;
  if (!scalar_check (x, 2))
    return false;

  return true;
}


bool
gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
{
  extern int gfc_max_integer_kind;

  /* If i and j are both BOZ, convert to widest INTEGER.  */
  if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
    {
      if (!gfc_boz2int (i, gfc_max_integer_kind))
	return false;
      if (!gfc_boz2int (j, gfc_max_integer_kind))
	return false;
    }

  /* If i is BOZ and j is integer, convert i to type of j.  */
  if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
      && !gfc_boz2int (i, j->ts.kind))
    return false;

  /* If j is BOZ and i is integer, convert j to type of i.  */
  if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
      && !gfc_boz2int (j, i->ts.kind))
    return false;

  if (!type_check (i, 0, BT_INTEGER))
    return false;

  if (!type_check (j, 1, BT_INTEGER))
    return false;

  return true;
}


bool
gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
{
  if (!type_check (i, 0, BT_INTEGER))
    return false;

  if (!type_check (pos, 1, BT_INTEGER))
    return false;

  if (!nonnegative_check ("pos", pos))
    return false;

  if (!less_than_bitsize1 ("i", i, "pos", pos, false))
    return false;

  return true;
}


bool
gfc_check_char (gfc_expr *i, gfc_expr *kind)
{
  if (i->ts.type == BT_BOZ)
    {
      if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
			   "CHAR intrinsic subprogram"), &i->where))
	return false;

      if (!gfc_boz2int (i, gfc_default_integer_kind))
	return false;
    }

  if (!type_check (i, 0, BT_INTEGER))
    return false;

  if (!kind_check (kind, 1, BT_CHARACTER))
    return false;

  return true;
}


bool
gfc_check_chdir (gfc_expr *dir)
{
  if (!type_check (dir, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (dir, 0, gfc_default_character_kind))
    return false;

  return true;
}


bool
gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
{
  if (!type_check (dir, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (dir, 0, gfc_default_character_kind))
    return false;

  if (status == NULL)
    return true;

  if (!type_check (status, 1, BT_INTEGER))
    return false;
  if (!scalar_check (status, 1))
    return false;

  return true;
}


bool
gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
{
  if (!type_check (name, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (name, 0, gfc_default_character_kind))
    return false;

  if (!type_check (mode, 1, BT_CHARACTER))
    return false;
  if (!kind_value_check (mode, 1, gfc_default_character_kind))
    return false;

  return true;
}


bool
gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
{
  if (!type_check (name, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (name, 0, gfc_default_character_kind))
    return false;

  if (!type_check (mode, 1, BT_CHARACTER))
    return false;
  if (!kind_value_check (mode, 1, gfc_default_character_kind))
    return false;

  if (status == NULL)
    return true;

  if (!type_check (status, 2, BT_INTEGER))
    return false;

  if (!scalar_check (status, 2))
    return false;

  return true;
}


bool
gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
{
  int k;

  /* Check kind first, because it may be needed in conversion of a BOZ.  */
  if (kind)
    {
      if (!kind_check (kind, 2, BT_COMPLEX))
	return false;
      gfc_extract_int (kind, &k);
    }
  else
    k = gfc_default_complex_kind;

  if (x->ts.type == BT_BOZ && !gfc_boz2real (x, k))
    return false;

  if (!numeric_check (x, 0))
    return false;

  if (y != NULL)
    {
      if (y->ts.type == BT_BOZ && !gfc_boz2real (y, k))
	return false;

      if (!numeric_check (y, 1))
	return false;

      if (x->ts.type == BT_COMPLEX)
	{
	  gfc_error ("%qs argument of %qs intrinsic at %L must not be "
		     "present if %<x%> is COMPLEX",
		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
		     &y->where);
	  return false;
	}

      if (y->ts.type == BT_COMPLEX)
	{
	  gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
		     "of either REAL or INTEGER",
		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
		     &y->where);
	  return false;
	}
    }

  if (!kind && warn_conversion
      && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
    gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
		     "COMPLEX(%d) at %L might lose precision, consider using "
		     "the KIND argument", gfc_typename (&x->ts),
		     gfc_default_real_kind, &x->where);
  else if (y && !kind && warn_conversion
	   && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind)
    gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
		     "COMPLEX(%d) at %L might lose precision, consider using "
		     "the KIND argument", gfc_typename (&y->ts),
		     gfc_default_real_kind, &y->where);
  return true;
}


static bool
check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
		    gfc_expr *errmsg, bool co_reduce)
{
  if (!variable_check (a, 0, false))
    return false;

  if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with "
				 "INTENT(INOUT)"))
    return false;

  /* Fortran 2008, 12.5.2.4, paragraph 18.  */
  if (gfc_has_vector_subscript (a))
    {
      gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
		 "subroutine %s shall not have a vector subscript",
		 &a->where, gfc_current_intrinsic);
      return false;
    }

  if (gfc_is_coindexed (a))
    {
      gfc_error ("The A argument at %L to the intrinsic %s shall not be "
		 "coindexed", &a->where, gfc_current_intrinsic);
      return false;
    }

  if (image_idx != NULL)
    {
      if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
	return false;
      if (!scalar_check (image_idx, co_reduce ? 2 : 1))
	return false;
    }

  if (stat != NULL)
    {
      if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER))
	return false;
      if (!scalar_check (stat, co_reduce ? 3 : 2))
	return false;
      if (!variable_check (stat, co_reduce ? 3 : 2, false))
	return false;
      if (stat->ts.kind != 4)
	{
	  gfc_error ("The stat= argument at %L must be a kind=4 integer "
		     "variable", &stat->where);
	  return false;
	}
    }

  if (errmsg != NULL)
    {
      if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER))
	return false;
      if (!scalar_check (errmsg, co_reduce ? 4 : 3))
	return false;
      if (!variable_check (errmsg, co_reduce ? 4 : 3, false))
	return false;
      if (errmsg->ts.kind != 1)
	{
	  gfc_error ("The errmsg= argument at %L must be a default-kind "
		     "character variable", &errmsg->where);
	  return false;
	}
    }

  if (flag_coarray == GFC_FCOARRAY_NONE)
    {
      gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
		       &a->where);
      return false;
    }

  return true;
}


bool
gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
			gfc_expr *errmsg)
{
  if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
    {
      gfc_error ("Support for the A argument at %L which is polymorphic A "
		 "argument or has allocatable components is not yet "
		 "implemented", &a->where);
      return false;
    }
  return check_co_collective (a, source_image, stat, errmsg, false);
}


bool
gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
		     gfc_expr *stat, gfc_expr *errmsg)
{
  symbol_attribute attr;
  gfc_formal_arglist *formal;
  gfc_symbol *sym;

  if (a->ts.type == BT_CLASS)
    {
      gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
		 &a->where);
      return false;
    }

  if (gfc_expr_attr (a).alloc_comp)
    {
      gfc_error ("Support for the A argument at %L with allocatable components"
                 " is not yet implemented", &a->where);
      return false;
    }

  if (!check_co_collective (a, result_image, stat, errmsg, true))
    return false;

  if (!gfc_resolve_expr (op))
    return false;

  attr = gfc_expr_attr (op);
  if (!attr.pure || !attr.function)
    {
      gfc_error ("OPERATION argument at %L must be a PURE function",
		 &op->where);
      return false;
    }

  if (attr.intrinsic)
    {
      /* None of the intrinsics fulfills the criteria of taking two arguments,
	 returning the same type and kind as the arguments and being permitted
	 as actual argument.  */
      gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
		 op->symtree->n.sym->name, &op->where);
      return false;
    }

  if (gfc_is_proc_ptr_comp (op))
    {
      gfc_component *comp = gfc_get_proc_ptr_comp (op);
      sym = comp->ts.interface;
    }
  else
    sym = op->symtree->n.sym;

  formal = sym->formal;

  if (!formal || !formal->next || formal->next->next)
    {
      gfc_error ("The function passed as OPERATION at %L shall have two "
		 "arguments", &op->where);
      return false;
    }

  if (sym->result->ts.type == BT_UNKNOWN)
    gfc_set_default_type (sym->result, 0, NULL);

  if (!gfc_compare_types (&a->ts, &sym->result->ts))
    {
      gfc_error ("The A argument at %L has type %s but the function passed as "
		 "OPERATION at %L returns %s",
		 &a->where, gfc_typename (a), &op->where,
		 gfc_typename (&sym->result->ts));
      return false;
    }
  if (!gfc_compare_types (&a->ts, &formal->sym->ts)
      || !gfc_compare_types (&a->ts, &formal->next->sym->ts))
    {
      gfc_error ("The function passed as OPERATION at %L has arguments of type "
		 "%s and %s but shall have type %s", &op->where,
		 gfc_typename (&formal->sym->ts),
		 gfc_typename (&formal->next->sym->ts), gfc_typename (a));
      return false;
    }
  if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
      || formal->next->sym->as || formal->sym->attr.allocatable
      || formal->next->sym->attr.allocatable || formal->sym->attr.pointer
      || formal->next->sym->attr.pointer)
    {
      gfc_error ("The function passed as OPERATION at %L shall have scalar "
		 "nonallocatable nonpointer arguments and return a "
		 "nonallocatable nonpointer scalar", &op->where);
      return false;
    }

  if (formal->sym->attr.value != formal->next->sym->attr.value)
    {
      gfc_error ("The function passed as OPERATION at %L shall have the VALUE "
		 "attribute either for none or both arguments", &op->where);
      return false;
    }

  if (formal->sym->attr.target != formal->next->sym->attr.target)
    {
      gfc_error ("The function passed as OPERATION at %L shall have the TARGET "
		 "attribute either for none or both arguments", &op->where);
      return false;
    }

  if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
    {
      gfc_error ("The function passed as OPERATION at %L shall have the "
		 "ASYNCHRONOUS attribute either for none or both arguments",
		 &op->where);
      return false;
    }

  if (formal->sym->attr.optional || formal->next->sym->attr.optional)
    {
      gfc_error ("The function passed as OPERATION at %L shall not have the "
		 "OPTIONAL attribute for either of the arguments", &op->where);
      return false;
    }

  if (a->ts.type == BT_CHARACTER)
    {
      gfc_charlen *cl;
      unsigned long actual_size, formal_size1, formal_size2, result_size;

      cl = a->ts.u.cl;
      actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
		     ? mpz_get_ui (cl->length->value.integer) : 0;

      cl = formal->sym->ts.u.cl;
      formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
		     ? mpz_get_ui (cl->length->value.integer) : 0;

      cl = formal->next->sym->ts.u.cl;
      formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
		     ? mpz_get_ui (cl->length->value.integer) : 0;

      cl = sym->ts.u.cl;
      result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
		    ? mpz_get_ui (cl->length->value.integer) : 0;

      if (actual_size
	  && ((formal_size1 && actual_size != formal_size1)
	       || (formal_size2 && actual_size != formal_size2)))
	{
	  gfc_error ("The character length of the A argument at %L and of the "
		     "arguments of the OPERATION at %L shall be the same",
		     &a->where, &op->where);
	  return false;
	}
      if (actual_size && result_size && actual_size != result_size)
	{
	  gfc_error ("The character length of the A argument at %L and of the "
		     "function result of the OPERATION at %L shall be the same",
		     &a->where, &op->where);
	  return false;
	}
    }

  return true;
}


bool
gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
		     gfc_expr *errmsg)
{
  if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
      && a->ts.type != BT_CHARACTER)
    {
       gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
		  "integer, real or character",
		  gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
		  &a->where);
       return false;
    }
  return check_co_collective (a, result_image, stat, errmsg, false);
}


bool
gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
		  gfc_expr *errmsg)
{
  if (!numeric_check (a, 0))
    return false;
  return check_co_collective (a, result_image, stat, errmsg, false);
}


bool
gfc_check_complex (gfc_expr *x, gfc_expr *y)
{
  if (!boz_args_check (x, y))
    return false;

  if (x->ts.type == BT_BOZ)
    {
      if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
			   " intrinsic subprogram"), &x->where))
	{
	  reset_boz (x);
	  return false;
        }
      if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind))
	return false;
      if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind))
    	return false;
    }

  if (y->ts.type == BT_BOZ)
    {
      if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
			   " intrinsic subprogram"), &y->where))
	{
	  reset_boz (y);
	  return false;
	}
      if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind))
	return false;
      if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind))
	return false;
    }

  if (!int_or_real_check (x, 0))
    return false;
  if (!scalar_check (x, 0))
    return false;

  if (!int_or_real_check (y, 1))
    return false;
  if (!scalar_check (y, 1))
    return false;

  return true;
}


bool
gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
  if (!logical_array_check (mask, 0))
    return false;
  if (!dim_check (dim, 1, false))
    return false;
  if (!dim_rank_check (dim, mask, 0))
    return false;
  if (!kind_check (kind, 2, BT_INTEGER))
    return false;
  if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
			       "with KIND argument at %L",
			       gfc_current_intrinsic, &kind->where))
    return false;

  return true;
}


bool
gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
{
  if (!array_check (array, 0))
    return false;

  if (!type_check (shift, 1, BT_INTEGER))
    return false;

  if (!dim_check (dim, 2, true))
    return false;

  if (!dim_rank_check (dim, array, false))
    return false;

  if (array->rank == 1 || shift->rank == 0)
    {
      if (!scalar_check (shift, 1))
	return false;
    }
  else if (shift->rank == array->rank - 1)
    {
      int d;
      if (!dim)
	d = 1;
      else if (dim->expr_type == EXPR_CONSTANT)
	gfc_extract_int (dim, &d);
      else
	d = -1;

      if (d > 0)
	{
	  int i, j;
	  for (i = 0, j = 0; i < array->rank; i++)
	    if (i != d - 1)
	      {
		if (!identical_dimen_shape (array, i, shift, j))
		  {
		    gfc_error ("%qs argument of %qs intrinsic at %L has "
			       "invalid shape in dimension %d (%ld/%ld)",
			       gfc_current_intrinsic_arg[1]->name,
			       gfc_current_intrinsic, &shift->where, i + 1,
			       mpz_get_si (array->shape[i]),
			       mpz_get_si (shift->shape[j]));
		    return false;
		  }

		j += 1;
	      }
	}
    }
  else
    {
      gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
		 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
		 gfc_current_intrinsic, &shift->where, array->rank - 1);
      return false;
    }

  return true;
}


bool
gfc_check_ctime (gfc_expr *time)
{
  if (!scalar_check (time, 0))
    return false;

  if (!type_check (time, 0, BT_INTEGER))
    return false;

  return true;
}


bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
{
  if (!double_check (y, 0) || !double_check (x, 1))
    return false;

  return true;
}

bool
gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
{
  if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
    return false;

  if (!numeric_check (x, 0))
    return false;

  if (y != NULL)
    {
      if (y->ts.type == BT_BOZ && !gfc_boz2real (y, gfc_default_double_kind))
	return false;

      if (!numeric_check (y, 1))
	return false;

      if (x->ts.type == BT_COMPLEX)
	{
	  gfc_error ("%qs argument of %qs intrinsic at %L must not be "
		     "present if %<x%> is COMPLEX",
		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
		     &y->where);
	  return false;
	}

      if (y->ts.type == BT_COMPLEX)
	{
	  gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
		     "of either REAL or INTEGER",
		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
		     &y->where);
	  return false;
	}
    }

  return true;
}


bool
gfc_check_dble (gfc_expr *x)
{
  if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
    return false;

  if (!numeric_check (x, 0))
    return false;

  return true;
}


bool
gfc_check_digits (gfc_expr *x)
{
  if (!int_or_real_check (x, 0))
    return false;

  return true;
}


bool
gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
{
  switch (vector_a->ts.type)
    {
    case BT_LOGICAL:
      if (!type_check (vector_b, 1, BT_LOGICAL))
	return false;
      break;

    case BT_INTEGER:
    case BT_REAL:
    case BT_COMPLEX:
      if (!numeric_check (vector_b, 1))
	return false;
      break;

    default:
      gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
		 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic, &vector_a->where);
      return false;
    }

  if (!rank_check (vector_a, 0, 1))
    return false;

  if (!rank_check (vector_b, 1, 1))
    return false;

  if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
    {
      gfc_error ("Different shape for arguments %qs and %qs at %L for "
		 "intrinsic %<dot_product%>",
		 gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic_arg[1]->name, &vector_a->where);
      return false;
    }

  return true;
}


bool
gfc_check_dprod (gfc_expr *x, gfc_expr *y)
{
  if (!type_check (x, 0, BT_REAL)
      || !type_check (y, 1, BT_REAL))
    return false;

  if (x->ts.kind != gfc_default_real_kind)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be default "
		 "real", gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic, &x->where);
      return false;
    }

  if (y->ts.kind != gfc_default_real_kind)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be default "
		 "real", gfc_current_intrinsic_arg[1]->name,
		 gfc_current_intrinsic, &y->where);
      return false;
    }

  return true;
}

bool
gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
{
  /* i and j cannot both be BOZ literal constants.  */
  if (!boz_args_check (i, j))
    return false;

  /* If i is BOZ and j is integer, convert i to type of j.  If j is not
     an integer, clear the BOZ; otherwise, check that i is an integer.  */
  if (i->ts.type == BT_BOZ)
    {
      if (j->ts.type != BT_INTEGER)
        reset_boz (i);
      else if (!gfc_boz2int (i, j->ts.kind))
	return false;
    }
  else if (!type_check (i, 0, BT_INTEGER))
    {
      if (j->ts.type == BT_BOZ)
	reset_boz (j);
      return false;
    }

  /* If j is BOZ and i is integer, convert j to type of i.  If i is not
     an integer, clear the BOZ; otherwise, check that i is an integer.  */
  if (j->ts.type == BT_BOZ)
    {
      if (i->ts.type != BT_INTEGER)
        reset_boz (j);
      else if (!gfc_boz2int (j, i->ts.kind))
	return false;
    }
  else if (!type_check (j, 1, BT_INTEGER))
    return false;

  if (!same_type_check (i, 0, j, 1))
    return false;

  if (!type_check (shift, 2, BT_INTEGER))
    return false;

  if (!nonnegative_check ("SHIFT", shift))
    return false;

  if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
    return false;

  return true;
}


bool
gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
		   gfc_expr *dim)
{
  int d;

  if (!array_check (array, 0))
    return false;

  if (!type_check (shift, 1, BT_INTEGER))
    return false;

  if (!dim_check (dim, 3, true))
    return false;

  if (!dim_rank_check (dim, array, false))
    return false;

  if (!dim)
    d = 1;
  else if (dim->expr_type == EXPR_CONSTANT)
    gfc_extract_int (dim, &d);
  else
    d = -1;

  if (array->rank == 1 || shift->rank == 0)
    {
      if (!scalar_check (shift, 1))
	return false;
    }
  else if (shift->rank == array->rank - 1)
    {
      if (d > 0)
	{
	  int i, j;
	  for (i = 0, j = 0; i < array->rank; i++)
	    if (i != d - 1)
	      {
		if (!identical_dimen_shape (array, i, shift, j))
		  {
		    gfc_error ("%qs argument of %qs intrinsic at %L has "
			       "invalid shape in dimension %d (%ld/%ld)",
			       gfc_current_intrinsic_arg[1]->name,
			       gfc_current_intrinsic, &shift->where, i + 1,
			       mpz_get_si (array->shape[i]),
			       mpz_get_si (shift->shape[j]));
		    return false;
		  }

		j += 1;
	      }
	}
    }
  else
    {
      gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
		 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
		 gfc_current_intrinsic, &shift->where, array->rank - 1);
      return false;
    }

  if (boundary != NULL)
    {
      if (!same_type_check (array, 0, boundary, 2))
	return false;

      /* Reject unequal string lengths and emit a better error message than
       gfc_check_same_strlen would.  */
      if (array->ts.type == BT_CHARACTER)
	{
	  ssize_t len_a, len_b;

	  len_a = gfc_var_strlen (array);
	  len_b = gfc_var_strlen (boundary);
	  if (len_a != -1 && len_b != -1 && len_a != len_b)
	    {
	      gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
			 gfc_current_intrinsic_arg[2]->name,
			 gfc_current_intrinsic_arg[0]->name,
			 &boundary->where, gfc_current_intrinsic);
	      return false;
	    }
	}

      if (array->rank == 1 || boundary->rank == 0)
	{
	  if (!scalar_check (boundary, 2))
	    return false;
	}
      else if (boundary->rank == array->rank - 1)
	{
	  if (d > 0)
	    {
	      int i,j;
	      for (i = 0, j = 0; i < array->rank; i++)
		{
		  if (i != d - 1)
		    {
		      if (!identical_dimen_shape (array, i, boundary, j))
			{
			  gfc_error ("%qs argument of %qs intrinsic at %L has "
				     "invalid shape in dimension %d (%ld/%ld)",
				     gfc_current_intrinsic_arg[2]->name,
				     gfc_current_intrinsic, &shift->where, i+1,
				     mpz_get_si (array->shape[i]),
				     mpz_get_si (boundary->shape[j]));
			  return false;
			}
		      j += 1;
		    }
		}
	    }
	}
      else
	{
	  gfc_error ("%qs argument of intrinsic %qs at %L of must have "
		     "rank %d or be a scalar",
		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
		     &shift->where, array->rank - 1);
	  return false;
	}
    }
  else
    {
      switch (array->ts.type)
	{
	case BT_INTEGER:
	case BT_LOGICAL:
	case BT_REAL:
	case BT_COMPLEX:
	case BT_CHARACTER:
	  break;

	default:
	  gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
		     "of type %qs", gfc_current_intrinsic_arg[2]->name,
		     gfc_current_intrinsic, &array->where,
		     gfc_current_intrinsic_arg[0]->name,
		     gfc_typename (array));
	  return false;
	}
    }

  return true;
}


bool
gfc_check_float (gfc_expr *a)
{
  if (a->ts.type == BT_BOZ)
    {
      if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the"
			   " FLOAT intrinsic subprogram"), &a->where))
	{
	  reset_boz (a);
	  return false;
	}
      if (!gfc_boz2int (a, gfc_default_integer_kind))
	return false;
    }

  if (!type_check (a, 0, BT_INTEGER))
    return false;

  if ((a->ts.kind != gfc_default_integer_kind)
      && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
			  "kind argument to %s intrinsic at %L",
			  gfc_current_intrinsic, &a->where))
    return false;

  return true;
}

/* A single complex argument.  */

bool
gfc_check_fn_c (gfc_expr *a)
{
  if (!type_check (a, 0, BT_COMPLEX))
    return false;

  return true;
}


/* A single real argument.  */

bool
gfc_check_fn_r (gfc_expr *a)
{
  if (!type_check (a, 0, BT_REAL))
    return false;

  return true;
}

/* A single double argument.  */

bool
gfc_check_fn_d (gfc_expr *a)
{
  if (!double_check (a, 0))
    return false;

  return true;
}

/* A single real or complex argument.  */

bool
gfc_check_fn_rc (gfc_expr *a)
{
  if (!real_or_complex_check (a, 0))
    return false;

  return true;
}


bool
gfc_check_fn_rc2008 (gfc_expr *a)
{
  if (!real_or_complex_check (a, 0))
    return false;

  if (a->ts.type == BT_COMPLEX
      && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs "
			  "of %qs intrinsic at %L",
			  gfc_current_intrinsic_arg[0]->name,
			  gfc_current_intrinsic, &a->where))
    return false;

  return true;
}


bool
gfc_check_fnum (gfc_expr *unit)
{
  if (!type_check (unit, 0, BT_INTEGER))
    return false;

  if (!scalar_check (unit, 0))
    return false;

  return true;
}


bool
gfc_check_huge (gfc_expr *x)
{
  if (!int_or_real_check (x, 0))
    return false;

  return true;
}


bool
gfc_check_hypot (gfc_expr *x, gfc_expr *y)
{
  if (!type_check (x, 0, BT_REAL))
    return false;
  if (!same_type_check (x, 0, y, 1))
    return false;

  return true;
}


/* Check that the single argument is an integer.  */

bool
gfc_check_i (gfc_expr *i)
{
  if (!type_check (i, 0, BT_INTEGER))
    return false;

  return true;
}


bool
gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
{
  /* i and j cannot both be BOZ literal constants.  */
  if (!boz_args_check (i, j))
    return false;

  /* If i is BOZ and j is integer, convert i to type of j.  */
  if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
      && !gfc_boz2int (i, j->ts.kind))
    return false;

  /* If j is BOZ and i is integer, convert j to type of i.  */
  if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
      && !gfc_boz2int (j, i->ts.kind))
    return false;

  if (!type_check (i, 0, BT_INTEGER))
    return false;

  if (!type_check (j, 1, BT_INTEGER))
    return false;

  if (i->ts.kind != j->ts.kind)
    {