gcc/fortran/check.c

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


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

  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)
    {
      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_ref *ref;
      bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
		     && CLASS_DATA (e->symtree->n.sym)
		     ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
		     : e->symtree->n.sym->attr.pointer;

      for (ref = e->ref; ref; ref = ref->next)
	{
	  if (pointer && ref->type == REF_COMPONENT)
	    break;
	  if (ref->type == REF_COMPONENT
	      && ((ref->u.c.component->ts.type == BT_CLASS
		   && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
		  || (ref->u.c.component->ts.type != BT_CLASS
		      && ref->u.c.component->attr.pointer)))
	    break;
	}

      if (!ref)
	{
	  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;
    }

  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);
      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 (!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.c(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_check_associated (gfc_expr *pointer, gfc_expr *target)
{
  symbol_attribute attr1, attr2;
  int i;
  bool t;
  locus *where;

  where = &pointer->where;

  if (pointer->expr_type == EXPR_NULL)
    goto null_arg;

  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;

  where = &target->where;
  if (target->expr_type == EXPR_NULL)
    goto null_arg;

  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;
  if (!rank_check (target, 0, pointer->rank))
    t = false;
  if (target->rank > 0)
    {
      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;

null_arg:

  gfc_error ("NULL pointer at %L is not permitted as actual argument "
	     "of %qs intrinsic function", where, gfc_current_intrinsic);
  return false;

}


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)
{
  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 (!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)
{
  if (!numeric_check (x, 0))
    return false;

  if (y != NULL)
    {
      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_check (kind, 2, BT_COMPLEX))
    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 ("OPERATOR 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 OPERATOR 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 "
		 "OPERATOR at %L returns %s",
		 &a->where, gfc_typename (&a->ts), &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 OPERATOR 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->ts));
      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 OPERATOR 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 OPERATOR 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 OPERATOR 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 OPERATOR 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 OPERATOR 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 OPERATOR 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 OPERATOR 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 (!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 (!numeric_check (x, 0))
    return false;

  if (y != NULL)
    {
      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 (!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;
}


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

    }
  return true;
}


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

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

  if (!boz_args_check (i, j))
    return false;

  if (!i->is_boz && !j->is_boz && !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 (i->is_boz)
    {
      if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true))
    	return false;
      i->ts.kind = j->ts.kind;
    }
  else
    {
      if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
    	return false;
      j->ts.kind = i->ts.kind;
    }

  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->ts));
	  return false;
	}
    }

  return true;
}

bool
gfc_check_float (gfc_expr *a)
{
  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)
{
  if (!type_check (i, 0, BT_INTEGER))
    return false;

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

  if (!boz_args_check (i, j))
    return false;

  if (i->is_boz) i->ts.kind = j->ts.kind;
  if (j->is_boz) j->ts.kind = i->ts.kind;

  if (i->ts.kind != j->ts.kind)
    {
      gfc_error ("Arguments of %qs have different kind type parameters "
		 "at %L", gfc_current_intrinsic, &i->where);
	return false;
    }

  return true;
}


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

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

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

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

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

  if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len))
    return false;

  return true;
}


bool
gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
{
  int i;

  if (!type_check (c, 0, BT_CHARACTER))
    return false;

  if (!kind_check (kind, 1, 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;

  if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
    {
      gfc_expr *start;
      gfc_expr *end;
      gfc_ref *ref;

      /* Substring references don't have the charlength set.  */
      ref = c->ref;
      while (ref && ref->type != REF_SUBSTRING)
	ref = ref->next;

      gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);

      if (!ref)
	{
	  /* Check that the argument is length one.  Non-constant lengths
	     can't be checked here, so assume they are ok.  */
	  if (c->ts.u.cl && c->ts.u.cl->length)
	    {
	      /* If we already have a length for this expression then use it.  */
	      if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
		return true;
	      i = mpz_get_si (c->ts.u.cl->length->value.integer);
	    }
	  else
	    return true;
	}
      else
	{
	  start = ref->u.ss.start;
	  end = ref->u.ss.end;

	  gcc_assert (start);
	  if (end == NULL || end->expr_type != EXPR_CONSTANT
	      || start->expr_type != EXPR_CONSTANT)
	    return true;

	  i = mpz_get_si (end->value.integer) + 1
	    - mpz_get_si (start->value.integer);
	}
    }
  else
    return true;

  if (i != 1)
    {
      gfc_error ("Argument of %s at %L must be of length one",
		 gfc_current_intrinsic, &c->where);
      return false;
    }

  return true;
}


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

  return true;
}


bool
gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
		 gfc_expr *kind)
{
  if (!type_check (string, 0, BT_CHARACTER)
      || !type_check (substring, 1, BT_CHARACTER))
    return false;

  if (back != NULL && !type_check (back, 2, BT_LOGICAL))
    return false;

  if (!kind_check (kind, 3, 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;

  if (string->ts.kind != substring->ts.kind)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
		 "kind as %qs", gfc_current_intrinsic_arg[1]->name,
		 gfc_current_intrinsic, &substring->where,
		 gfc_current_intrinsic_arg[0]->name);
      return false;
    }

  return true;
}


bool
gfc_check_int (gfc_expr *x, gfc_expr *kind)
{
  if (!numeric_check (x, 0))
    return false;

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

  return true;
}


bool
gfc_check_intconv (gfc_expr *x)
{
  if (!numeric_check (x, 0))
    return false;

  return true;
}

bool
gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
{
  if (!type_check (i, 0, BT_INTEGER)
      || !type_check (shift, 1, BT_INTEGER))
    return false;

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

  return true;
}


bool
gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
{
  if (!type_check (i, 0, BT_INTEGER)
      || !type_check (shift, 1, BT_INTEGER))
    return false;

  if (size != NULL)
    {
      int i2, i3;

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

      if (!less_than_bitsize1 ("I", i, "SIZE", size, true))
	return false;

      if (size->expr_type == EXPR_CONSTANT)
	{
	  gfc_extract_int (size, &i3);
	  if (i3 <= 0)
	    {
	      gfc_error ("SIZE at %L must be positive", &size->where);
	      return false;
	    }

	  if (shift->expr_type == EXPR_CONSTANT)
	    {
	      gfc_extract_int (shift, &i2);
	      if (i2 < 0)
		i2 = -i2;

	      if (i2 > i3)
		{
		  gfc_error ("The absolute value of SHIFT at %L must be less "
			     "than or equal to SIZE at %L", &shift->where,
			     &size->where);
		  return false;
		}
	     }
	}
    }
  else if (!less_than_bitsize1 ("I", i, NULL, shift, true))
    return false;

  return true;
}


bool
gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
{
  if (!type_check (pid, 0, BT_INTEGER))
    return false;

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

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

  if (!scalar_check (sig, 1))
    return false;

  return true;
}


bool
gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
{
  if (!type_check (pid, 0, BT_INTEGER))
    return false;

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

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

  if (!scalar_check (sig, 1))
    return false;

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

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

      if (status->expr_type != EXPR_VARIABLE)
	{
	  gfc_error ("STATUS at %L shall be an INTENT(OUT) variable",
		     &status->where);
	  return false;
	}

      if (status->expr_type == EXPR_VARIABLE
	  && status->symtree && status->symtree->n.sym
	  && status->symtree->n.sym->attr.intent == INTENT_IN)
	{
	  gfc_error ("%qs at %L shall be an INTENT(OUT) variable",
		     status->symtree->name, &status->where);
	  return false;
	}
    }

  return true;
}


bool
gfc_check_kind (gfc_expr *x)
{
  if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be of "
		 "intrinsic type", gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic, &x->where);
      return false;
    }
  if (x->ts.type == BT_PROCEDURE)
    {
      gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
		 &x->where);
      return false;
    }

  return true;
}


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

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

  if (!dim_rank_check (dim, array, 1))
    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_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
{
  if (flag_coarray == GFC_FCOARRAY_NONE)
    {
      gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
      return false;
    }

  if (!coarray_check (coarray, 0))
    return false;

  if (dim != NULL)
    {
      if (!dim_check (dim, 1, false))
        return false;

      if (!dim_corank_check (dim, coarray))
        return false;
    }

  if (!kind_check (kind, 2, BT_INTEGER))
    return false;

  return true;
}


bool
gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
{
  if (!type_check (s, 0, BT_CHARACTER))
    return false;

  if (!kind_check (kind, 1, 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_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
{
  if (!type_check (a, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (a, 0, gfc_default_character_kind))
    return false;

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

  return true;
}


bool
gfc_check_link (gfc_expr *path1, gfc_expr *path2)
{
  if (!type_check (path1, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (path1, 0, gfc_default_character_kind))
    return false;

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

  return true;
}


bool
gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
  if (!type_check (path1, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (path1, 0, gfc_default_character_kind))
    return false;

  if (!type_check (path2, 1, BT_CHARACTER))
    return false;
  if (!kind_value_check (path2, 0, 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_loc (gfc_expr *expr)
{
  return variable_check (expr, 0, true);
}


bool
gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
{
  if (!type_check (path1, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (path1, 0, gfc_default_character_kind))
    return false;

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

  return true;
}


bool
gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
{
  if (!type_check (path1, 0, BT_CHARACTER))
    return false;
  if (!kind_value_check (path1, 0, gfc_default_character_kind))
    return false;

  if (!type_check (path2, 1, BT_CHARACTER))
    return false;
  if (!kind_value_check (path2, 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_logical (gfc_expr *a, gfc_expr *kind)
{
  if (!type_check (a, 0, BT_LOGICAL))
    return false;
  if (!kind_check (kind, 1, BT_LOGICAL))
    return false;

  return true;
}


/* Min/max family.  */

static bool
min_max_args (gfc_actual_arglist *args)
{
  gfc_actual_arglist *arg;
  int i, j, nargs, *nlabels, nlabelless;
  bool a1 = false, a2 = false;

  if (args == NULL || args->next == NULL)
    {
      gfc_error ("Intrinsic %qs at %L must have at least two arguments",
		 gfc_current_intrinsic, gfc_current_intrinsic_where);
      return false;
    }

  if (!args->name)
    a1 = true;

  if (!args->next->name)
    a2 = true;

  nargs = 0;
  for (arg = args; arg; arg = arg->next)
    if (arg->name)
      nargs++;

  if (nargs == 0)
    return true;

  /* Note: Having a keywordless argument after an "arg=" is checked before.  */
  nlabelless = 0;
  nlabels = XALLOCAVEC (int, nargs);
  for (arg = args, i = 0; arg; arg = arg->next, i++)
    if (arg->name)
      {
	int n;
	char *endp;

	if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
	  goto unknown;
	n = strtol (&arg->name[1], &endp, 10);
	if (endp[0] != '\0')
	  goto unknown;
	if (n <= 0)
	  goto unknown;
	if (n <= nlabelless)
	  goto duplicate;
	nlabels[i] = n;
	if (n == 1)
	  a1 = true;
	if (n == 2)
	  a2 = true;
      }
    else
      nlabelless++;

  if (!a1 || !a2)
    {
      gfc_error ("Missing %qs argument to the %s intrinsic at %L",
	         !a1 ? "a1" : "a2", gfc_current_intrinsic,
		 gfc_current_intrinsic_where);
      return false;
    }

  /* Check for duplicates.  */
  for (i = 0; i < nargs; i++)
    for (j = i + 1; j < nargs; j++)
      if (nlabels[i] == nlabels[j])
	goto duplicate;

  return true;

duplicate:
  gfc_error (