/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/check.cc

Bug Summary

File:	build/gcc/fortran/check.cc
Warning:	line 3651, column 22 The left operand of '==' is a garbage value
Annotated Source Code

Press '?' to see keyboard shortcuts
Show analyzer invocation
clang -cc1 -cc1 -triple x86_64-suse-linux -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name check.cc -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/15.0.7 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/backward -internal-isystem /usr/lib64/clang/15.0.7/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2023-03-27-141847-20772-1/report-YX6QvD.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/check.cc
1/* Check functions
 Copyright (C) 2002-2023 Free Software Foundation, Inc.
 Contributed by Andy Vaught & Katherine Holcomb

5This file is part of GCC.

7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.

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

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


22/* 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.  */

28#include "config.h"
29#include "system.h"
30#include "coretypes.h"
31#include "options.h"
32#include "gfortran.h"
33#include "intrinsic.h"
34#include "constructor.h"
35#include "target-memory.h"


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

41static void
42reset_boz (gfc_expr *x)
43{
/* 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__gmpz_init (x->value.integer);
mpz_set_ui__gmpz_set_ui (x->value.integer, 0);
53}

55/* 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.  */

61bool
62gfc_invalid_boz (const char *msg, locus *loc)
63{
if (flag_allow_invalid_bozglobal_options.x_flag_allow_invalid_boz)
  {
    gfc_warning (0, msg, loc);
    return false;
  }

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


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

82static bool
83illegal_boz_arg (gfc_expr *x)
84{
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;
94}

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

98static bool
99boz_args_check(gfc_expr *i, gfc_expr *j)
100{
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;
113}


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

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

return true;
128}


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

134static char *
135oct2bin(int nbits, char *oct)
136{
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)((char *) xcalloc ((j + 1), sizeof (char)));
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)((char *) xcalloc ((nbits + 1), sizeof (char)));
if (nbits == 64)
  strcpy (bufp, buf + 2);
else
  strcpy (bufp, buf + 1);

free (buf);

return bufp;
166}


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

172static char *
173hex2bin(int nbits, char *hex)
174{
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)((char *) xcalloc ((nbits + 1), sizeof (char)));
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 ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/check.cc"
, 196, __FUNCTION__));

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

 return buf;
203}


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

208static void
209bin2real (gfc_expr *x, int kind)
210{
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__gmpz_init (em);
mpz_set_str__gmpz_set_str (em, buf, 2);
ie = mpz_get_si__gmpz_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__gmpz_set_str (em, buf, 2);
    ie -= ((1 << (w - 1)) - 1);	/* Unbiased exponent. */
    mpfr_set_z_2exp (x->value.real, em, ie - t, GFC_RND_MODEMPFR_RNDN);
  }

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

 mpz_clear__gmpz_clear (em);
289}


292/* 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.  */

296bool
297gfc_boz2real (gfc_expr *x, int kind)
298{
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)__builtin_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)((char *) xcalloc ((len + 1), sizeof (char)));
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;
377}


380/* 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.  */

386bool
387gfc_boz2int (gfc_expr *x, int kind)
388{
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)__builtin_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__gmpz_init (tmp1);
mpz_set_str__gmpz_set_str (tmp1, buf, x->boz.rdx);

/* Check for wrap-around.  */
if (mpz_cmp__gmpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0)
  {
    mpz_t tmp2;
    mpz_init__gmpz_init (tmp2);
    mpz_add_ui__gmpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1);
    mpz_mod__gmpz_mod (tmp1, tmp1, tmp2);
    mpz_sub__gmpz_sub (tmp1, tmp1, tmp2);
    mpz_clear__gmpz_clear (tmp2);
  }

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

mpz_init__gmpz_init (x->value.integer);
mpz_set__gmpz_set (x->value.integer, tmp1);
x->ts.type = BT_INTEGER;
x->ts.kind = kind;
mpz_clear__gmpz_clear (tmp1);

return true;
466}


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

471static bool
472scalar_check (gfc_expr *e, int n)
473{
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;
482}


485/* Check the type of an expression.  */

487static bool
488type_check (gfc_expr *e, int n, bt type)
489{
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;
498}


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

503static bool
504numeric_check (gfc_expr *e, int n)
505{
/* 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;
  }

525error:

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;
532}


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

537static bool
538int_or_real_check (gfc_expr *e, int n)
539{
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;
549}

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

554static bool
555int_or_real_or_char_check_f2003 (gfc_expr *e, int n)
556{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
  {
    if (e->ts.type == BT_CHARACTER)
return gfc_notify_std (GFC_STD_F2003(1<<4), "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(1<<4))
   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;
580}

582/* Check that an expression is an intrinsic type.  */
583static bool
584intrinsic_type_check (gfc_expr *e, int n)
585{
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;
596}

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

600static bool
601real_or_complex_check (gfc_expr *e, int n)
602{
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;
612}


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

617static bool
618int_or_proc_check (gfc_expr *e, int n)
619{
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;
629}


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

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

if (k == NULL__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;
666}


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

671static bool
672double_check (gfc_expr *d, int n)
673{
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;
686}


689static bool
690coarray_check (gfc_expr *e, int n)
691{
if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
&& CLASS_DATA (e)e->ts.u.derived->components->attr.codimension
&& CLASS_DATA (e)e->ts.u.derived->components->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;
709}


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

714static bool
715logical_array_check (gfc_expr *array, int n)
716{
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;
726}


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

731static bool
732array_check (gfc_expr *e, int n)
733{
if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
&& CLASS_DATA (e)e->ts.u.derived->components->attr.dimension
&& CLASS_DATA (e)e->ts.u.derived->components->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;
749}


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

755static bool
756nonnegative_check (const char *arg, gfc_expr *expr)
757{
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;
771}


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

776static bool
777positive_check (int n, gfc_expr *expr)
778{
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;
794}


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

800static bool
801less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
    gfc_expr *expr2, bool or_equal)
803{
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__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;
848}


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

854static bool
855less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
856{
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;
873}


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

879static bool
880less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
      gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
882{
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;
901}

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

905static bool
906same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
907{
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;
932}


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

937static bool
938rank_check (gfc_expr *e, int n, int rank)
939{
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;
948}


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

953static bool
954nonoptional_check (gfc_expr *e, int n)
955{
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;
966}


969/* Check for ALLOCATABLE attribute.  */

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

attr = gfc_variable_attr (e, NULL__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;
987}


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

992static bool
993kind_value_check (gfc_expr *e, int n, int k)
994{
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;
1003}


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

1008static bool
1009variable_check (gfc_expr *e, int n, bool allow_proc)
1010{
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__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;
1048}


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

1053static bool
1054dim_check (gfc_expr *dim, int n, bool optional)
1055{
if (dim == NULL__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;
1069}


1072/* 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.  */

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

gcc_assert (array->expr_type == EXPR_VARIABLE)((void)(!(array->expr_type == EXPR_VARIABLE) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/check.cc"
, 1080, __FUNCTION__), 0 : 0));

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)(__builtin_constant_p (1) && (1) == 0 ? ((dim->value
.integer)->_mp_size < 0 ? -1 : (dim->value.integer)->
_mp_size > 0) : __gmpz_cmp_ui (dim->value.integer,1)) < 0
    || mpz_cmp_ui (dim->value.integer, corank)(__builtin_constant_p (corank) && (corank) == 0 ? ((dim
->value.integer)->_mp_size < 0 ? -1 : (dim->value
.integer)->_mp_size > 0) : __gmpz_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;
1100}


1103/* 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.  */

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

if (dim == NULL__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_DIMENSIONS15;

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)(__builtin_constant_p (1) && (1) == 0 ? ((dim->value
.integer)->_mp_size < 0 ? -1 : (dim->value.integer)->
_mp_size > 0) : __gmpz_cmp_ui (dim->value.integer,1)) < 0
    || mpz_cmp_ui (dim->value.integer, rank)(__builtin_constant_p (rank) && (rank) == 0 ? ((dim->
value.integer)->_mp_size < 0 ? -1 : (dim->value.integer
)->_mp_size > 0) : __gmpz_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;
1152}


1155/* 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.  */

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

gcc_assert (a->rank > ai)((void)(!(a->rank > ai) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/check.cc"
, 1165, __FUNCTION__), 0 : 0));
gcc_assert (b->rank > bi)((void)(!(b->rank > bi) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/check.cc"
, 1166, __FUNCTION__), 0 : 0));

ret = 1;

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

 mpz_clear__gmpz_clear (b_size);
}
    mpz_clear__gmpz_clear (a_size);
  }
return ret;
1182}

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

1188static long
1189gfc_var_strlen (const gfc_expr *a)
1190{
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__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__gmpz_get_si (ra->u.ss.start->value.integer)
		   : 1;
 end_a = mpz_get_si__gmpz_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__gmpz_get_si (a->ts.u.cl->length->value.integer);
else if (a->expr_type == EXPR_CONSTANT
  && (a->ts.u.cl == NULL__null || a->ts.u.cl->length == NULL__null))
  return a->value.character.length;
else
  return -1;

1230}

1232/* 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.  */

1236bool
1237gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
1238{
 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;
   }
1252}


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

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

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

return true;
1269}


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

1274bool
1275gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
1276{
return check_a_kind (a, kind, BT_INTEGER);
1278}


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

1283bool
1284gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
1285{
return check_a_kind (a, kind, BT_REAL);
1287}


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

return true;
1297}


1300bool
1301gfc_check_achar (gfc_expr *a, gfc_expr *kind)
1302{
if (a->ts.type == BT_BOZ)
  {
    if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in ""BOZ literal constant at %L cannot appear in " "ACHAR intrinsic subprogram"
	   "ACHAR intrinsic subprogram")"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;
1320}


1323bool
1324gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
1325{
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;
1339}


1342bool
1343gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
1344{
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;
1355}


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

1362bool
1363gfc_check_allocated (gfc_expr *array)
1364{
/* Tests on allocated components of coarrays need to detour the check to
   argument of the _caf_get.  */
if (flag_coarrayglobal_options.x_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;
1382}


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

1388bool
1389gfc_check_a_p (gfc_expr *a, gfc_expr *p)
1390{
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(1<<5), "Different type kinds at %L",
	   &p->where))
     return false;
  }

return true;
1411}


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

return true;
1421}

1423bool
1424gfc_invalid_null_arg (gfc_expr *x)
1425{
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;
1434}

1436bool
1437gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
1438{
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__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;
1520}


1523bool
1524gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
1525{
/* 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(1<<7)) == 0)
  return false;

return gfc_check_atan2 (y, x);
1533}


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

return true;
1545}


1548static bool
1549gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
  gfc_expr *stat, int stat_no)
1551{
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__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(1<<9), "STAT= argument to %s at %L",
	   gfc_current_intrinsic, &stat->where))
return false;
  }

return true;
1598}


1601bool
1602gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
1603{
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__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);
1617}


1620bool
1621gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
1622{
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);
1632}


1635bool
1636gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
1637{
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__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);
1651}


1654bool
1655gfc_check_image_status (gfc_expr *image, gfc_expr *team)
1656{
/* 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;
1670}


1673bool
1674gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
1675{
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;
1705}


1708bool
1709gfc_check_get_team (gfc_expr *level)
1710{
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;
1719}


1722bool
1723gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
      gfc_expr *new_val,  gfc_expr *stat)
1725{
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__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__null))
  {
    gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
 "definable", gfc_current_intrinsic, &old->where);
    return false;
  }

return true;
1758}

1760bool
1761gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
1762{
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__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__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(1<<9), "STAT= argument to %s at %L",
	   gfc_current_intrinsic, &stat->where))
return false;
  }

return true;
1811}


1814bool
1815gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
	   gfc_expr *stat)
1817{
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__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__null))
  {
    gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
 "definable", gfc_current_intrinsic, &old->where);
    return false;
  }

return true;
1855}


1858/* BESJN and BESYN functions.  */

1860bool
1861gfc_check_besn (gfc_expr *n, gfc_expr *x)
1862{
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(1<<5), "Negative argument "
		    "N at %L", &n->where))
return false;
  }

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

return true;
1878}


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

1883bool
1884gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
1885{
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;
1906}


1909bool
1910gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
1911{
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;
1940}


1943bool
1944gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
1945{
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;
1959}


1962bool
1963gfc_check_char (gfc_expr *i, gfc_expr *kind)
1964{
if (i->ts.type == BT_BOZ)
  {
    if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in ""BOZ literal constant at %L cannot appear in " "CHAR intrinsic subprogram"
	   "CHAR intrinsic subprogram")"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;
1982}


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

return true;
1994}


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

if (status == NULL__null)
  return true;

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

return true;
2014}


2017bool
2018gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
2019{
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;
2031}


2034bool
2035gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
2036{
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__null)
  return true;

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

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

return true;
2057}


2060bool
2061gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
2062{
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__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_conversionglobal_options.x_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_conversionglobal_options.x_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;
2121}


2124static bool
2125check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
    gfc_expr *errmsg, bool co_reduce)
2127{
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__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__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__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_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
  {
    gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
       &a->where);
    return false;
  }

return true;
2199}


2202bool
2203gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
	gfc_expr *errmsg)
2205{
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);
2214}


2217bool
2218gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
     gfc_expr *stat, gfc_expr *errmsg)
2220{
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__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__gmpz_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__gmpz_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__gmpz_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__gmpz_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;
2380}


2383bool
2384gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
     gfc_expr *errmsg)
2386{
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);
2397}


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


2410bool
2411gfc_check_complex (gfc_expr *x, gfc_expr *y)
2412{
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""BOZ constant at %L cannot appear in the COMPLEX" " intrinsic subprogram"
	   " intrinsic subprogram")"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""BOZ constant at %L cannot appear in the COMPLEX" " intrinsic subprogram"
	   " intrinsic subprogram")"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;
2455}


2458bool
2459gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
2460{
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(1<<4), "%qs intrinsic "
	       "with KIND argument at %L",
	       gfc_current_intrinsic, &kind->where))
  return false;

return true;
2475}


2478bool
2479gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
2480{
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__gmpz_get_si (array->shape[i]),
	       mpz_get_si__gmpz_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;
2538}


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

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

return true;
2551}


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

return true;
2560}

2562bool
2563gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
2564{
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__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;
2599}


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

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

return true;
2612}


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

return true;
2622}


2625bool
2626gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2627{
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;
2665}


2668bool
2669gfc_check_dprod (gfc_expr *x, gfc_expr *y)
2670{
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;
2692}

2694bool
2695gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
2696{
/* 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;
2742}


2745bool
2746gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
   gfc_expr *dim)
2748{
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__gmpz_get_si (array->shape[i]),
	       mpz_get_si__gmpz_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__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__gmpz_get_si (array->shape[i]),
		     mpz_get_si__gmpz_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;
2889}


2892bool
2893gfc_check_float (gfc_expr *a)
2894{
if (a->ts.type == BT_BOZ)
  {
    if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the""BOZ literal constant at %L cannot appear in the" " FLOAT intrinsic subprogram"
	   " FLOAT intrinsic subprogram")"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(1<<5), "non-default INTEGER "
	  "kind argument to %s intrinsic at %L",
	  gfc_current_intrinsic, &a->where))
  return false;

return true;
2917}

2919/* A single complex argument.  */

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

return true;
2928}


2931/* A single real argument.  */

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

return true;
2940}

2942/* A single double argument.  */

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

return true;
2951}

2953/* A single real or complex argument.  */

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

return true;
2962}


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

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

return true;
2979}


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

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

return true;
2992}


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

return true;
3002}


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

return true;
3014}


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

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

return true;
3026}


3029bool
3030gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
3031{
/* 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)
  {
    gfc_error ("Arguments of %qs have different kind type parameters "
 "at %L", gfc_current_intrinsic, &i->where);
return false;
  }

return true;
3060}


3063bool
3064gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
3065{
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;
3085}


3088bool
3089gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
3090{
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(1<<4), "%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)((void)(!(ref == __null || ref->type == REF_SUBSTRING) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/check.cc"
, 3115, __FUNCTION__), 0 : 0));

    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__gmpz_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)((void)(!(start) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/check.cc"
, 3136, __FUNCTION__), 0 : 0));
 if (end == NULL__null || end->expr_type != EXPR_CONSTANT
     || start->expr_type != EXPR_CONSTANT)
   return true;

 i = mpz_get_si__gmpz_get_si (end->value.integer) + 1
   - mpz_get_si__gmpz_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;
3156}


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

return true;
3166}


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

if (back != NULL__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(1<<4), "%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;
3197}


3200bool
3201gfc_check_int (gfc_expr *x, gfc_expr *kind)
3202{
/* BOZ is dealt within simplify_int*.  */
if (x->ts.type == BT_BOZ)
  return true;

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

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

return true;
3214}


3217bool
3218gfc_check_intconv (gfc_expr *x)
3219{
if (strcmp (gfc_current_intrinsic, "short") == 0
    || strcmp (gfc_current_intrinsic, "long") == 0)
  {
    gfc_error ("%qs intrinsic subprogram at %L has been removed.  "
 "Use INT intrinsic subprogram.", gfc_current_intrinsic,
 &x->where);
    return false;
  }

/* BOZ is dealt within simplify_int*.  */
if (x->ts.type == BT_BOZ)
  return true;

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

return true;
3237}

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

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

return true;
3250}


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

if (size != NULL__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__null, shift, true))
  return false;

return true;
3299}


3302bool
3303gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
3304{
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;
3318}


3321bool
3322gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
3323{
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;
3362}


3365bool
3366gfc_check_kind (gfc_expr *x)
3367{
if (gfc_invalid_null_arg (x))
  return false;

if (gfc_bt_struct (x->ts.type)((x->ts.type) == BT_DERIVED || (x->ts.type) == BT_UNION
) || 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;
3387}


3390bool
3391gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3392{
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(1<<4), "%qs intrinsic "
	       "with KIND argument at %L",
	       gfc_current_intrinsic, &kind->where))
  return false;

return true;
3410}


3413bool
3414gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
3415{
if (flag_coarrayglobal_options.x_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__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;
3438}


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

if (gfc_invalid_null_arg (s))
  return false;

if (!kind_check (kind, 1, BT_INTEGER))
  return false;
if (kind && !gfc_notify_std (GFC_STD_F2003(1<<4), "%qs intrinsic "
	       "with KIND argument at %L",
	       gfc_current_intrinsic, &kind->where))
  return false;

return true;
3458}


3461bool
3462gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
3463{
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;
3475}


3478bool
3479gfc_check_link (gfc_expr *path1, gfc_expr *path2)
3480{
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;
3492}


3495bool
3496gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3497{
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__null)
  return true;

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

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

return true;
3518}


3521bool
3522gfc_check_loc (gfc_expr *expr)
3523{
return variable_check (expr, 0, true);
3525}


3528bool
3529gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
3530{
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;
3542}


3545bool
3546gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
3547{
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__null)
  return true;

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

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

return true;
3568}


3571bool
3572gfc_check_logical (gfc_expr *a, gfc_expr *kind)
3573{
if (!type_check (a, 0, BT_LOGICAL))
  return false;
if (!kind_check (kind, 1, BT_LOGICAL))
  return false;

return true;
3580}


3583/* Min/max family.  */

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

if (args == NULL__null || args->next == NULL__null)
3
←
Assuming 'args' is not equal to NULL→
4
←
Assuming field 'next' is not equal to NULL→
5
←
Taking false branch→
  {
    gfc_error ("Intrinsic %qs at %L must have at least two arguments",
 gfc_current_intrinsic, gfc_current_intrinsic_where);
    return false;
  }

if (!args->name)
6
←
Assuming field 'name' is null→
7
←
Taking true branch→
  a1 = true;

if (!args->next->name)
8
←
Assuming field 'name' is non-null→
9
←
Taking false branch→
  a2 = true;

nargs = 0;
for (arg = args; arg; arg = arg->next)
10
←
Loop condition is true.  Entering loop body→
12
←
Loop condition is true.  Entering loop body→
14
←
Loop condition is true.  Entering loop body→
17
←
Assuming pointer value is null→
18
←
Loop condition is false. Execution continues on line 3610→
  if (arg->name10.1
Field 'name' is null
1
Field 'name' is non-null
)
11
←
Taking false branch→
13
←
Taking true branch→
15
←
Assuming field 'name' is non-null→
16
←
Taking true branch→
    nargs++;

if (nargs18.1
'nargs' is not equal to 0
 == 0)
19
←
Taking false branch→
  return true;

/* Note: Having a keywordless argument after an "arg=" is checked before.  */
nlabelless = 0;
nlabels = XALLOCAVEC (int, nargs)((int *) __builtin_alloca(sizeof (int) * (nargs)));
for (arg = args, i = 0; arg; arg = arg->next, i++)
20
←
Loop condition is true.  Entering loop body→
22
←
Loop condition is true.  Entering loop body→
37
←
Loop condition is true.  Entering loop body→
  if (arg->name20.1
Field 'name' is null
1
Field 'name' is non-null
1
Field 'name' is non-null
)
21
←
Taking false branch→
23
←
Taking true branch→
38
←
Taking true branch→
    {
int n;
char *endp;

if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
24
←
Assuming the condition is false→
25
←
Assuming the condition is false→
26
←
Assuming the condition is false→
27
←
Taking false branch→
39
←
Assuming the condition is false→
40
←
Assuming the condition is false→
41
←
Assuming the condition is false→
42
←
Taking false branch→
 goto unknown;
n = strtol (&arg->name[1], &endp, 10);
if (endp[0] != '\0')
28
←
Assuming the condition is false→
29
←
Taking false branch→
43
←
Assuming the condition is false→
44
←
Taking false branch→
 goto unknown;
if (n <= 0)
30
←
Assuming 'n' is > 0→
31
←
Taking false branch→
45
←
Assuming 'n' is > 0→
46
←
Taking false branch→
 goto unknown;
if (n <= nlabelless)
32
←
Assuming 'n' is > 'nlabelless'→
33
←
Taking false branch→
47
←
Assuming 'n' is > 'nlabelless'→
48
←
Taking false branch→
 goto duplicate;
nlabels[i] = n;
if (n33.1
'n' is not equal to 1
1
'n' is not equal to 1
 == 1)
34
←
Taking false branch→
49
←
Taking false branch→
 a1 = true;
if (n == 2)
35
←
Assuming 'n' is equal to 2→
36
←
Taking true branch→
50
←
Assuming 'n' is not equal to 2→
51
←
Taking false branch→
 a2 = true;
    }
  else
    nlabelless++;

if (!a151.1
'a1' is true
 || !a251.2
'a2' is true
)
52
←
Taking false branch→
  {
    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++)
53
←
The value 0 is assigned to 'i'→
54
←
Loop condition is true.  Entering loop body→
  for (j = i + 1; j < nargs; j++)
55
←
Loop condition is true.  Entering loop body→
    if (nlabels[i] == nlabels[j])
56
←
The left operand of '==' is a garbage value
goto duplicate;

return true;

3656duplicate:
gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
    &arg->expr->where, gfc_current_intrinsic);
return false;

3661unknown:
gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
    &arg->expr->where, gfc_current_intrinsic);
return false;
3665}


3668static bool
3669check_rest (bt type, int kind, gfc_actual_arglist *arglist)
3670{
gfc_actual_arglist *arg, *tmp;
gfc_expr *x;
int m, n;

if (!min_max_args (arglist))
2
←
Calling 'min_max_args'→
  return false;

for (arg = arglist, n=1; arg; arg = arg->next, n++)
  {
    x = arg->expr;
    if (x->ts.type != type || x->ts.kind != kind)
{
 if (x->ts.type == type)
   {
     if (x->ts.type == BT_CHARACTER)
{
  gfc_error ("Different character kinds at %L", &x->where);
  return false;
}
     if (!gfc_notify_std (GFC_STD_GNU(1<<5), "Different type "
		   "kinds at %L", &x->where))
return false;
   }
 else
   {
     gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
	 "%s(%d)", n, gfc_current_intrinsic, &x->where,
	 gfc_basic_typename (type), kind);
     return false;
   }
}

    for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
if (!gfc_check_conformance (tmp->expr, x,
		    _("arguments 'a%d' and 'a%d' for "gettext ("arguments 'a%d' and 'a%d' for " "intrinsic '%s'")
		    "intrinsic '%s'")gettext ("arguments 'a%d' and 'a%d' for " "intrinsic '%s'"), m, n,
		    gfc_current_intrinsic))
   return false;
  }

return true;
3712}


3715bool
3716gfc_check_min_max (gfc_actual_arglist *arg)
3717{
gfc_expr *x;

if (!min_max_args (arg))
  return false;

x = arg->expr;

if (x->ts.type == BT_CHARACTER)
  {
    if (!gfc_notify_std (GFC_STD_F2003(1<<4), "%qs intrinsic "
	   "with CHARACTER argument at %L",
	   gfc_current_intrinsic, &x->where))
return false;
  }
else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
  {
    gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
    return false;
  }

return check_rest (x->ts.type, x->ts.kind, arg);
3740}


3743bool
3744gfc_check_min_max_integer (gfc_actual_arglist *arg)
3745{
return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
3747}


3750bool
3751gfc_check_min_max_real (gfc_actual_arglist *arg)
3752{
return check_rest (BT_REAL, gfc_default_real_kind, arg);
3754}


3757bool
3758gfc_check_min_max_double (gfc_actual_arglist *arg)
3759{
return check_rest (BT_REAL, gfc_default_double_kind, arg);
1
Calling 'check_rest'→
3761}


3764/* End of min/max family.  */

3766bool
3767gfc_check_malloc (gfc_expr *size)
3768{
if (!type_check (size, 0, BT_INTEGER))
  return false;

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

return true;
3776}


3779bool
3780gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3781{
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
 gfc_current_intrinsic, &matrix_a->where);
    return false;
  }

if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
 gfc_current_intrinsic, &matrix_b->where);
    return false;
  }

if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
    || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
  {
    gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
 gfc_current_intrinsic, &matrix_a->where,
 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
     return false;
  }

switch (matrix_a->rank)
  {
  case 1:
    if (!rank_check (matrix_b, 1, 2))
return false;
    /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
    if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
{
 gfc_error ("Different shape on dimension 1 for arguments %qs "
     "and %qs at %L for intrinsic matmul",
     gfc_current_intrinsic_arg[0]->name,
     gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
 return false;
}
    break;

  case 2:
    if (matrix_b->rank != 2)
{
 if (!rank_check (matrix_b, 1, 1))
   return false;
}
    /* matrix_b has rank 1 or 2 here. Common check for the cases
- matrix_a has shape (n,m) and matrix_b has shape (m, k)
- matrix_a has shape (n,m) and matrix_b has shape (m).  */
    if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
{
 gfc_error ("Different shape on dimension 2 for argument %qs and "
     "dimension 1 for argument %qs at %L for intrinsic "
     "matmul", gfc_current_intrinsic_arg[0]->name,
     gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
 return false;
}
    break;

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

return true;
3850}


3853/* Whoever came up with this interface was probably on something.
 The possibilities for the occupation of the second and third
 parameters are:

Arg #2     Arg #3
NULL       NULL
DIM	NULL
MASK       NULL
NULL       MASK	     minloc(array, mask=m)
DIM	MASK

 I.e. in the case of minloc(array,mask), mask will be in the second
 position of the argument list and we'll have to fix that up.  Also,
 add the BACK argument if that isn't present.  */

3868bool
3869gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
3870{
gfc_expr *a, *m, *d, *k, *b;

a = ap->expr;
if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0))
  return false;

d = ap->next->expr;
m = ap->next->next->expr;
k = ap->next->next->next->expr;
b = ap->next->next->next->next->expr;

if (b)
  {
    if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4))
return false;
  }
else
  {
    b = gfc_get_logical_expr (gfc_logical_4_kind4, NULL__null, 0);
    ap->next->next->next->next->expr = b;
    ap->next->next->next->next->name = gfc_get_string ("back");
  }

if (m == NULL__null && d != NULL__null && d->ts.type == BT_LOGICAL
    && ap->next->name == NULL__null)
  {
    m = d;
    d = NULL__null;
    ap->next->expr = NULL__null;
    ap->next->next->expr = m;
  }

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

if (!dim_rank_check (d, a, 0))
  return false;

if (m != NULL__null && !type_check (m, 2, BT_LOGICAL))
  return false;

if (m != NULL__null
    && !gfc_check_conformance (a, m,
		 _("arguments '%s' and '%s' for intrinsic %s")gettext ("arguments '%s' and '%s' for intrinsic %s"),
		 gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic_arg[2]->name,
		 gfc_current_intrinsic))
  return false;

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

return true;
3924}

3926/* Check function for findloc.  Mostly like gfc_check_minloc_maxloc
 above, with the additional "value" argument.  */

3929bool
3930gfc_check_findloc (gfc_actual_arglist *ap)
3931{
gfc_expr *a, *v, *m, *d, *k, *b;
bool a1, v1;

a = ap->expr;
if (!intrinsic_type_check (a, 0) || !array_check (a, 0))
  return false;

v = ap->next->expr;
if (!intrinsic_type_check (v, 1) || !scalar_check (v,1))
  return false;

/* Check if the type are both logical.  */
a1 = a->ts.type == BT_LOGICAL;
v1 = v->ts.type == BT_LOGICAL;
if ((a1 && !v1) || (!a1 && v1))
  goto incompat;

/* Check if the type are both character.  */
a1 = a->ts.type == BT_CHARACTER;
v1 = v->ts.type == BT_CHARACTER;
if ((a1 && !v1) || (!a1 && v1))
  goto incompat;

/* Check the kind of the characters argument match.  */
if (a1 && v1 && a->ts.kind != v->ts.kind)
  goto incompat;

d = ap->next->next->expr;
m = ap->next->next->next->expr;
k = ap->next->next->next->next->expr;
b = ap->next->next->next->next->next->expr;

if (b)
  {
    if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4))
return false;
  }
else
  {
    b = gfc_get_logical_expr (gfc_logical_4_kind4, NULL__null, 0);
    ap->next->next->next->next->next->expr = b;
    ap->next->next->next->next->next->name = gfc_get_string ("back");
  }

if (m == NULL__null && d != NULL__null && d->ts.type == BT_LOGICAL
    && ap->next->name == NULL__null)
  {
    m = d;
    d = NULL__null;
    ap->next->next->expr = NULL__null;
    ap->next->next->next->expr = m;
  }

if (!dim_check (d, 2, false))
  return false;

if (!dim_rank_check (d, a, 0))
  return false;

if (m != NULL__null && !type_check (m, 3, BT_LOGICAL))
  return false;

if (m != NULL__null
    && !gfc_check_conformance (a, m,
		 _("arguments '%s' and '%s' for intrinsic %s")gettext ("arguments '%s' and '%s' for intrinsic %s"),
		 gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic_arg[3]->name,
		 gfc_current_intrinsic))
  return false;

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

return true;

4007incompat:
gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
    "conformance to argument %qs at %L",
    gfc_current_intrinsic_arg[0]->name,
    gfc_current_intrinsic, &a->where,
    gfc_current_intrinsic_arg[1]->name, &v->where);
return false;
4014}


4017/* Similar to minloc/maxloc, the argument list might need to be
 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
 difference is that MINLOC/MAXLOC take an additional KIND argument.
 The possibilities are:

Arg #2     Arg #3
NULL       NULL
DIM	NULL
MASK       NULL
NULL       MASK	     minval(array, mask=m)
DIM	MASK

 I.e. in the case of minval(array,mask), mask will be in the second
 position of the argument list and we'll have to fix that up.  */

4032static bool
4033check_reduction (gfc_actual_arglist *ap)
4034{
gfc_expr *a, *m, *d;

a = ap->expr;
d = ap->next->expr;
m = ap->next->next->expr;

if (m == NULL__null && d != NULL__null && d->ts.type == BT_LOGICAL
    && ap->next->name == NULL__null)
  {
    m = d;
    d = NULL__null;
    ap->next->expr = NULL__null;
    ap->next->next->expr = m;
  }

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

if (!dim_rank_check (d, a, 0))
  return false;

if (m != NULL__null && !type_check (m, 2, BT_LOGICAL))
  return false;

if (m != NULL__null
    && !gfc_check_conformance (a, m,
		 _("arguments '%s' and '%s' for intrinsic %s")gettext ("arguments '%s' and '%s' for intrinsic %s"),
		 gfc_current_intrinsic_arg[0]->name,
		 gfc_current_intrinsic_arg[2]->name,
		 gfc_current_intrinsic))
  return false;

return true;
4068}


4071bool
4072gfc_check_minval_maxval (gfc_actual_arglist *ap)
4073{
if (!int_or_real_or_char_check_f2003 (ap->expr, 0)
    || !array_check (ap->expr, 0))
  return false;

return check_reduction (ap);
4079}


4082bool
4083gfc_check_product_sum (gfc_actual_arglist *ap)
4084{
if (!numeric_check (ap->expr, 0)
    || !array_check (ap->expr, 0))
  return false;

return check_reduction (ap);
4090}


4093/* For IANY, IALL and IPARITY.  */

4095bool
4096gfc_check_mask (gfc_expr *i, gfc_expr *kind)
4097{
int k;

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

if (!nonnegative_check ("I", i))
  return false;

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

if (kind)
  gfc_extract_int (kind, &k);
else
  k = gfc_default_integer_kind;

if (!less_than_bitsizekind ("I", i, k))
  return false;

return true;
4118}


4121bool
4122gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
4123{
if (ap->expr->ts.type != BT_INTEGER)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
               gfc_current_intrinsic_arg[0]->name,
               gfc_current_intrinsic, &ap->expr->where);
    return false;
  }

if (!array_check (ap->expr, 0))
  return false;

return check_reduction (ap);
4136}


4139bool
4140gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4141{
if (gfc_invalid_null_arg (tsource))
  return false;

if (gfc_invalid_null_arg (fsource))
  return false;

if (!same_type_check (tsource, 0, fsource, 1))
  return false;

if (!type_check (mask, 2, BT_LOGICAL))
  return false;

if (tsource->ts.type == BT_CHARACTER)
  return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");

return true;
4158}


4161bool
4162gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
4163{
/* 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 (!same_type_check (i, 0, j, 1))
  return false;

if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind))
  return false;

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

if (!same_type_check (i, 0, mask, 2))
  return false;

return true;
4197}


4200bool
4201gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
4202{
if (!variable_check (from, 0, false))
  return false;
if (!allocatable_check (from, 0))
  return false;
if (gfc_is_coindexed (from))
  {
    gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
 "coindexed", &from->where);
    return false;
  }

if (!variable_check (to, 1, false))
  return false;
if (!allocatable_check (to, 1))
  return false;
if (gfc_is_coindexed (to))
  {
    gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
 "coindexed", &to->where);
    return false;
  }

if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
  {
    gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
 "polymorphic if FROM is polymorphic",
 &to->where);
    return false;
  }

if (!same_type_check (to, 1, from, 0))
  return false;

if (to->rank != from->rank)
  {
    gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
 "must have the same rank %d/%d", &to->where,  from->rank,
 to->rank);
    return false;
  }

/* IR F08/0040; cf. 12-006A.  */
if (gfc_get_corank (to) != gfc_get_corank (from))
  {
    gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
 "must have the same corank %d/%d", &to->where,
 gfc_get_corank (from), gfc_get_corank (to));
    return false;
  }

/*  This is based losely on F2003 12.4.1.7. It is intended to prevent
    the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
    and cmp2 are allocatable.  After the allocation is transferred,
    the 'to' chain is broken by the nullification of the 'from'. A bit
    of reflection reveals that this can only occur for derived types
    with recursive allocatable components.  */
if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
    && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
  {
    gfc_ref *to_ref, *from_ref;
    to_ref = to->ref;
    from_ref = from->ref;
    bool aliasing = true;

    for (; from_ref && to_ref;
  from_ref = from_ref->next, to_ref = to_ref->next)
{
 if (to_ref->type != from->ref->type)
   aliasing = false;
 else if (to_ref->type == REF_ARRAY
   && to_ref->u.ar.type != AR_FULL
   && from_ref->u.ar.type != AR_FULL)
   /* Play safe; assume sections and elements are different.  */
   aliasing = false;
 else if (to_ref->type == REF_COMPONENT
   && to_ref->u.c.component != from_ref->u.c.component)
   aliasing = false;

 if (!aliasing)
   break;
}

    if (aliasing)
{
 gfc_error ("The FROM and TO arguments at %L violate aliasing "
     "restrictions (F2003 12.4.1.7)", &to->where);
 return false;
}
  }

/* CLASS arguments: Make sure the vtab of from is present.  */
if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from)(from != __null && from->ts.type == BT_CLASS &&
 from->ts.u.derived->components && from->ts.
u.derived->components->ts.u.derived && from->
ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
))
  gfc_find_vtab (&from->ts);

return true;
4298}


4301bool
4302gfc_check_nearest (gfc_expr *x, gfc_expr *s)
4303{
if (!type_check (x, 0, BT_REAL))
  return false;

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

if (s->expr_type == EXPR_CONSTANT)
  {
    if (mpfr_sgn (s->value.real)((s->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (s->
value.real) : (mpfr_srcptr) (s->value.real)))->_mpfr_exp
 == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
 () : (mpfr_void) 0), 0 : ((s->value.real)->_mpfr_sign)
) == 0)
{
 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
     &s->where);
 return false;
}
  }

return true;
4321}


4324bool
4325gfc_check_new_line (gfc_expr *a)
4326{
if (!type_check (a, 0, BT_CHARACTER))
  return false;

return true;
4331}


4334bool
4335gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
4336{
if (!type_check (array, 0, BT_REAL))
  return false;

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

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

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

return true;
4350}

4352bool
4353gfc_check_null (gfc_expr *mold)
4354{
symbol_attribute attr;

if (mold == NULL__null)
  return true;

if (!variable_check (mold, 0, true))
  return false;

attr = gfc_variable_attr (mold, NULL__null);

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

if (attr.allocatable
    && !gfc_notify_std (GFC_STD_F2003(1<<4), "NULL intrinsic with "
	  "allocatable MOLD at %L", &mold->where))
  return false;

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

return true;
4389}


4392bool
4393gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4394{
if (!array_check (array, 0))
  return false;

if (!type_check (mask, 1, BT_LOGICAL))
  return false;

if (!gfc_check_conformance (array, mask,
	      _("arguments '%s' and '%s' for intrinsic '%s'")gettext ("arguments '%s' and '%s' for intrinsic '%s'"),
	      gfc_current_intrinsic_arg[0]->name,
	      gfc_current_intrinsic_arg[1]->name,
	      gfc_current_intrinsic))
  return false;

if (vector != NULL__null)
  {
    mpz_t array_size, vector_size;
    bool have_array_size, have_vector_size;

    if (!same_type_check (array, 0, vector, 2))
return false;

    if (!rank_check (vector, 2, 1))
return false;

    /* VECTOR requires at least as many elements as MASK
       has .TRUE. values.  */
    have_array_size = gfc_array_size(array, &array_size);
    have_vector_size = gfc_array_size(vector, &vector_size);

    if (have_vector_size
 && (mask->expr_type == EXPR_ARRAY
     || (mask->expr_type == EXPR_CONSTANT
  && have_array_size)))
{
 int mask_true_values = 0;

 if (mask->expr_type == EXPR_ARRAY)
   {
     gfc_constructor *mask_ctor;
     mask_ctor = gfc_constructor_first (mask->value.constructor);
     while (mask_ctor)
{
  if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
    {
      mask_true_values = 0;
      break;
    }

  if (mask_ctor->expr->value.logical)
    mask_true_values++;

  mask_ctor = gfc_constructor_next (mask_ctor);
}
   }
 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
   mask_true_values = mpz_get_si__gmpz_get_si (array_size);

 if (mpz_get_si__gmpz_get_si (vector_size) < mask_true_values)
   {
     gfc_error ("%qs argument of %qs intrinsic at %L must "
	 "provide at least as many elements as there "
	 "are .TRUE. values in %qs (%ld/%d)",
	 gfc_current_intrinsic_arg[2]->name,
	 gfc_current_intrinsic, &vector->where,
	 gfc_current_intrinsic_arg[1]->name,
	 mpz_get_si__gmpz_get_si (vector_size), mask_true_values);
     return false;
   }
}

    if (have_array_size)
mpz_clear__gmpz_clear (array_size);
    if (have_vector_size)
mpz_clear__gmpz_clear (vector_size);
  }

return true;
4472}


4475bool
4476gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
4477{
if (!type_check (mask, 0, BT_LOGICAL))
  return false;

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

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

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

return true;
4491}


4494bool
4495gfc_check_precision (gfc_expr *x)
4496{
if (!real_or_complex_check (x, 0))
  return false;

return true;
4501}


4504bool
4505gfc_check_present (gfc_expr *a)
4506{
gfc_symbol *sym;

if (!variable_check (a, 0, true))
  return false;

sym = a->symtree->n.sym;
if (!sym->attr.dummy)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
 "dummy variable", gfc_current_intrinsic_arg[0]->name,
 gfc_current_intrinsic, &a->where);
    return false;
  }

/* For CLASS, the optional attribute might be set at either location. */
if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)sym->ts.u.derived->components->attr.optional)
    && !sym->attr.optional)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must be of "
 "an OPTIONAL dummy variable",
 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 &a->where);
    return false;
  }

/* 13.14.82  PRESENT(A)
   ......
   Argument.  A shall be the name of an optional dummy argument that is
   accessible in the subprogram in which the PRESENT function reference
   appears...  */

if (a->ref != NULL__null
    && !(a->ref->next == NULL__null && a->ref->type == REF_ARRAY
  && (a->ref->u.ar.type == AR_FULL
      || (a->ref->u.ar.type == AR_ELEMENT
   && a->ref->u.ar.as->rank == 0))))
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
 "subobject of %qs", gfc_current_intrinsic_arg[0]->name,
 gfc_current_intrinsic, &a->where, sym->name);
    return false;
  }

return true;
4551}


4554bool
4555gfc_check_radix (gfc_expr *x)
4556{
if (!int_or_real_check (x, 0))
  return false;

return true;
4561}


4564bool
4565gfc_check_range (gfc_expr *x)
4566{
if (!numeric_check (x, 0))
  return false;

return true;
4571}


4574bool
4575gfc_check_rank (gfc_expr *a)
4576{
/* Any data object is allowed; a "data object" is a "constant (4.1.3),
   variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45).  */

bool is_variable = true;

/* Functions returning pointers are regarded as variable, cf. F2008, R602.  */
if (a->expr_type == EXPR_FUNCTION)
  is_variable = a->value.function.esym
  ? a->value.function.esym->result->attr.pointer
  : a->symtree->n.sym->result->attr.pointer;

if (a->expr_type == EXPR_OP
    || a->expr_type == EXPR_NULL
    || a->expr_type == EXPR_COMPCALL
    || a->expr_type == EXPR_PPC
    || a->ts.type == BT_PROCEDURE
    || !is_variable)
  {
    gfc_error ("The argument of the RANK intrinsic at %L must be a data "
 "object", &a->where);
    return false;
  }

return true;
4601}


4604bool
4605gfc_check_real (gfc_expr *a, gfc_expr *kind)
4606{
if (!kind_check (kind, 1, BT_REAL))
  return false;

/* BOZ is dealt with in gfc_simplify_real.  */
if (a->ts.type == BT_BOZ)
  return true;

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

return true;
4618}


4621bool
4622gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
4623{
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;
4635}


4638bool
4639gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
4640{
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__null)
  return true;

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

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

return true;
4661}


4664bool
4665gfc_check_repeat (gfc_expr *x, gfc_expr *y)
4666{
if (!type_check (x, 0, BT_CHARACTER))
  return false;

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

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

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

return true;
4680}


4683bool
4684gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
   gfc_expr *pad, gfc_expr *order)
4686{
mpz_t size;
mpz_t nelems;
int shape_size;
bool shape_is_const;

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

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

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

if (!gfc_array_size (shape, &size))
  {
    gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
 "array of constant size", &shape->where);
    return false;
  }

shape_size = mpz_get_ui__gmpz_get_ui (size);
mpz_clear__gmpz_clear (size);

if (shape_size <= 0)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L is empty",
 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 &shape->where);
    return false;
  }
else if (shape_size > GFC_MAX_DIMENSIONS15)
  {
    gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS15);
    return false;
  }

gfc_simplify_expr (shape, 0);
shape_is_const = gfc_is_constant_expr (shape);

if (shape->expr_type == EXPR_ARRAY && shape_is_const)
  {
    gfc_expr *e;
    int i, extent;
    for (i = 0; i < shape_size; ++i)
{
 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
 if (e->expr_type != EXPR_CONSTANT)
   continue;

 gfc_extract_int (e, &extent);
 if (extent < 0)
   {
     gfc_error ("%qs argument of %qs intrinsic at %L has "
	 "negative element (%d)",
	 gfc_current_intrinsic_arg[1]->name,
	 gfc_current_intrinsic, &shape->where, extent);
     return false;
   }
}
  }

if (pad != NULL__null)
  {
    if (!same_type_check (source, 0, pad, 2))
return false;

    if (!array_check (pad, 2))
return false;
  }

if (order != NULL__null)
  {
    if (!array_check (order, 3))
return false;

    if (!type_check (order, 3, BT_INTEGER))
return false;

    if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
{
 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS15];
 gfc_expr *e;

 for (i = 0; i < GFC_MAX_DIMENSIONS15; ++i)
   perm[i] = 0;

 gfc_array_size (order, &size);
 order_size = mpz_get_ui__gmpz_get_ui (size);
 mpz_clear__gmpz_clear (size);

 if (order_size != shape_size)
   {
     gfc_error ("%qs argument of %qs intrinsic at %L "
	 "has wrong number of elements (%d/%d)",
	 gfc_current_intrinsic_arg[3]->name,
	 gfc_current_intrinsic, &order->where,
	 order_size, shape_size);
     return false;
   }

 for (i = 1; i <= order_size; ++i)
   {
     e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
     if (e->expr_type != EXPR_CONSTANT)
continue;

     gfc_extract_int (e, &dim);

     if (dim < 1 || dim > order_size)
{
  gfc_error ("%qs argument of %qs intrinsic at %L "
	     "has out-of-range dimension (%d)",
	     gfc_current_intrinsic_arg[3]->name,
	     gfc_current_intrinsic, &e->where, dim);
  return false;
}

     if (perm[dim-1] != 0)
{
  gfc_error ("%qs argument of %qs intrinsic at %L has "
	     "invalid permutation of dimensions (dimension "
	     "%qd duplicated)",
	     gfc_current_intrinsic_arg[3]->name,
	     gfc_current_intrinsic, &e->where, dim);
  return false;
}

     perm[dim-1] = 1;
   }
}
  }

if (pad == NULL__null && shape->expr_type == EXPR_ARRAY && shape_is_const
    && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
  && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
  {
    /* Check the match in size between source and destination.  */
    if (gfc_array_size (source, &nelems))
{
 gfc_constructor *c;
 bool test;


 mpz_init_set_ui__gmpz_init_set_ui (size, 1);
 for (c = gfc_constructor_first (shape->value.constructor);
      c; c = gfc_constructor_next (c))
   mpz_mul__gmpz_mul (size, size, c->expr->value.integer);

 test = mpz_cmp__gmpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0)(__builtin_constant_p (0) && (0) == 0 ? ((size)->_mp_size
 < 0 ? -1 : (size)->_mp_size > 0) : __gmpz_cmp_ui (size
,0)) > 0;
 mpz_clear__gmpz_clear (nelems);
 mpz_clear__gmpz_clear (size);

 if (test)
   {
     gfc_error ("Without padding, there are not enough elements "
	 "in the intrinsic RESHAPE source at %L to match "
	 "the shape", &source->where);
     return false;
   }
}
  }

return true;
4852}


4855bool
4856gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
4857{
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
  {
      gfc_error ("%qs argument of %qs intrinsic at %L "
   "cannot be of type %s",
   gfc_current_intrinsic_arg[0]->name,
   gfc_current_intrinsic,
   &a->where, gfc_typename (a));
      return false;
  }

if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)(a != __null && a->ts.type == BT_CLASS && a
->ts.u.derived->components && a->ts.u.derived
->components->ts.u.derived && a->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)))
  {
    gfc_error ("%qs argument of %qs intrinsic at %L "
 "must be of an extensible type",
 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 &a->where);
    return false;
  }

if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
  {
      gfc_error ("%qs argument of %qs intrinsic at %L "
   "cannot be of type %s",
   gfc_current_intrinsic_arg[0]->name,
   gfc_current_intrinsic,
   &b->where, gfc_typename (b));
    return false;
  }

if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)(b != __null && b->ts.type == BT_CLASS && b
->ts.u.derived->components && b->ts.u.derived
->components->ts.u.derived && b->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)))
  {
    gfc_error ("%qs argument of %qs intrinsic at %L "
 "must be of an extensible type",
 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 &b->where);
    return false;
  }

return true;
4897}


4900bool
4901gfc_check_scale (gfc_expr *x, gfc_expr *i)
4902{
if (!type_check (x, 0, BT_REAL))
  return false;

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

return true;
4910}


4913bool
4914gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
4915{
if (!type_check (x, 0, BT_CHARACTER))
  return false;

if (!type_check (y, 1, BT_CHARACTER))
  return false;

if (z != NULL__null && !type_check (z, 2, BT_LOGICAL))
  return false;

if (!kind_check (kind, 3, BT_INTEGER))
  return false;
if (kind && !gfc_notify_std (GFC_STD_F2003(1<<4), "%qs intrinsic "
	       "with KIND argument at %L",
	       gfc_current_intrinsic, &kind->where))
  return false;

if (!same_type_check (x, 0, y, 1))
  return false;

return true;
4936}


4939bool
4940gfc_check_secnds (gfc_expr *r)
4941{
if (!type_check (r, 0, BT_REAL))
  return false;

if (!kind_value_check (r, 0, 4))
  return false;

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

return true;
4952}


4955bool
4956gfc_check_selected_char_kind (gfc_expr *name)
4957{
if (!type_check (name, 0, BT_CHARACTER))
  return false;

if (!kind_value_check (name, 0, gfc_default_character_kind))
  return false;

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

return true;
4968}


4971bool
4972gfc_check_selected_int_kind (gfc_expr *r)
4973{
if (!type_check (r, 0, BT_INTEGER))
  return false;

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

return true;
4981}


4984bool
4985gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
4986{
if (p == NULL__null && r == NULL__null
    && !gfc_notify_std (GFC_STD_F2008(1<<7), "SELECTED_REAL_KIND with"
	  " neither %<P%> nor %<R%> argument at %L",
	  gfc_current_intrinsic_where))
  return false;

if (p)
  {
    if (!type_check (p, 0, BT_INTEGER))
return false;

    if (!scalar_check (p, 0))
return false;
  }

if (r)
  {
    if (!type_check (r, 1, BT_INTEGER))
return false;

    if (!scalar_check (r, 1))
return false;
  }

if (radix)
  {
    if (!type_check (radix, 1, BT_INTEGER))
return false;

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

    if (!gfc_notify_std (GFC_STD_F2008(1<<7), "%qs intrinsic with "
	   "RADIX argument at %L", gfc_current_intrinsic,
	   &radix->where))
return false;
  }

return true;
5026}


5029bool
5030gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
5031{
if (!type_check (x, 0, BT_REAL))
  return false;

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

return true;
5039}


5042bool
5043gfc_check_shape (gfc_expr *source, gfc_expr *kind)
5044{
gfc_array_ref *ar;

if (gfc_invalid_null_arg (source))
  return false;

if (!kind_check (kind, 1, BT_INTEGER))
  return false;
if (kind && !gfc_notify_std (GFC_STD_F2003(1<<4), "%qs intrinsic "
	       "with KIND argument at %L",
	       gfc_current_intrinsic, &kind->where))
  return false;

if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
  return true;

if (source->ref == NULL__null)
  return false;

ar = gfc_find_array_ref (source);

if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
  {
    gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
 "an assumed size array", &source->where);
    return false;
  }

return true;
5073}


5076bool
5077gfc_check_shift (gfc_expr *i, gfc_expr *shift)
5078{
if (!type_check (i, 0, BT_INTEGER))
  return false;

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

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

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

return true;
5092}


5095bool
5096gfc_check_sign (gfc_expr *a, gfc_expr *b)
5097{
if (!int_or_real_check (a, 0))
  return false;

if (!same_type_check (a, 0, b, 1))
  return false;

return true;
5105}


5108bool
5109gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5110{
if (!array_check (array, 0))
  return false;

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

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

if (!kind_check (kind, 2, BT_INTEGER))
  return false;
if (kind && !gfc_notify_std (GFC_STD_F2003(1<<4), "%qs intrinsic "
	       "with KIND argument at %L",
	       gfc_current_intrinsic, &kind->where))
  return false;


return true;
5129}


5132bool
5133gfc_check_sizeof (gfc_expr *arg)
5134{
if (gfc_invalid_null_arg (arg))
  return false;

if (arg->ts.type == BT_PROCEDURE)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 &arg->where);
    return false;
  }

if (illegal_boz_arg (arg))
  return false;

/* TYPE(*) is acceptable if and only if it uses an array descriptor.  */
if (arg->ts.type == BT_ASSUMED
    && (arg->symtree->n.sym->as == NULL__null
 || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
     && arg->symtree->n.sym->as->type != AS_DEFERRED
     && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
  {
    gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 &arg->where);
    return false;
  }

if (arg->rank && arg->expr_type == EXPR_VARIABLE
    && arg->symtree->n.sym->as != NULL__null
    && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
    && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
 gfc_current_intrinsic, &arg->where);
    return false;
  }

return true;
5174}


5177/* Check whether an expression is interoperable.  When returning false,
 msg is set to a string telling why the expression is not interoperable,
 otherwise, it is set to NULL.  The msg string can be used in diagnostics.
 If c_loc is true, character with len > 1 are allowed (cf. Fortran
 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
 are permitted.  */

5185static bool
5186is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
5187{
*msg = NULL__null;

if (expr->expr_type == EXPR_NULL)
  {
    *msg = "NULL() is not interoperable";
    return false;
  }

if (expr->ts.type == BT_BOZ)
  {
    *msg = "BOZ literal constant";
    return false;
  }

if (expr->ts.type == BT_CLASS)
  {
    *msg = "Expression is polymorphic";
    return false;
  }

if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
    && !expr->ts.u.derived->ts.is_iso_c)
  {
    *msg = "Expression is a noninteroperable derived type";
    return false;
  }

if (expr->ts.type == BT_PROCEDURE)
  {
    *msg = "Procedure unexpected as argument";
    return false;
  }

if (gfc_notification_std (GFC_STD_GNU(1<<5)) && expr->ts.type == BT_LOGICAL)
  {
    int i;
    for (i = 0; gfc_logical_kinds[i].kind; i++)
      if (gfc_logical_kinds[i].kind == expr->ts.kind)
        return true;
    *msg = "Extension to use a non-C_Bool-kind LOGICAL";
    return false;
  }

if (gfc_notification_std (GFC_STD_GNU(1<<5)) && expr->ts.type == BT_CHARACTER
    && expr->ts.kind != 1)
  {
    *msg = "Extension to use a non-C_CHAR-kind CHARACTER";
    return false;
  }

if (expr->ts.type == BT_CHARACTER) {
  if (expr->ts.deferred)
    {
/* TS 29113 allows deferred-length strings as dummy arguments,
  but it is not an interoperable type.  */
*msg = "Expression shall not be a deferred-length string";
return false;
    }

  if (expr->ts.u.cl && expr->ts.u.cl->length
&& !gfc_simplify_expr (expr->ts.u.cl->length, 0))
    gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");

  if (!c_loc && expr->ts.u.cl
&& (!expr->ts.u.cl->length
   || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
   || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (1)))
 && ((static_cast<unsigned long> (1))) == 0 ? (
(expr->ts.u.cl->length->value.integer)->_mp_size <
? -1 : (expr->ts.u.cl->length->value.integer)->
_mp_size > 0) : __gmpz_cmp_ui (expr->ts.u.cl->length
->value.integer,(static_cast<unsigned long> (1)))) :
 __gmpz_cmp_si (expr->ts.u.cl->length->value.integer
,1)) != 0))
    {
*msg = "Type shall have a character length of 1";
return false;
    }
  }

/* Note: The following checks are about interoperatable variables, Fortran
   15.3.5/15.3.6.  In intrinsics like C_LOC or in procedure interface, more
   is allowed, e.g. assumed-shape arrays with TS 29113.  */

if (gfc_is_coarray (expr))
  {
    *msg = "Coarrays are not interoperable";
    return false;
  }

if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
  {
    gfc_array_ref *ar = gfc_find_array_ref (expr);
    if (ar->type != AR_FULL)
{
 *msg = "Only whole-arrays are interoperable";
 return false;
}
    if (!c_f_ptr && ar->as->type != AS_EXPLICIT
 && ar->as->type != AS_ASSUMED_SIZE)
{
 *msg = "Only explicit-size and assumed-size arrays are interoperable";
 return false;
}
  }

return true;
5288}


5291bool
5292gfc_check_c_sizeof (gfc_expr *arg)
5293{
const char *msg;

if (!is_c_interoperable (arg, &msg, false, false))
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must be an "
 "interoperable data entity: %s",
 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 &arg->where, msg);
    return false;
  }

if (arg->ts.type == BT_ASSUMED)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
 "TYPE(*)",
 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 &arg->where);
    return false;
  }

if (arg->rank && arg->expr_type == EXPR_VARIABLE
    && arg->symtree->n.sym->as != NULL__null
    && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
    && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
 gfc_current_intrinsic, &arg->where);
    return false;
  }

return true;
5326}


5329bool
5330gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
5331{
if (c_ptr_1->ts.type != BT_DERIVED
    || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
    || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
 && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
  {
    gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
    return false;
  }

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

if (c_ptr_2
    && (c_ptr_2->ts.type != BT_DERIVED
 || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
 || (c_ptr_1->ts.u.derived->intmod_sym_id
     != c_ptr_2->ts.u.derived->intmod_sym_id)))
  {
    gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
 "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
 gfc_typename (&c_ptr_1->ts),
 gfc_typename (&c_ptr_2->ts));
    return false;
  }

if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
  return false;

return true;
5362}


5365bool
5366gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
5367{
symbol_attribute attr;
const char *msg;

if (cptr->ts.type != BT_DERIVED
    || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
    || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
  {
    gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
 "type TYPE(C_PTR)", &cptr->where);
    return false;
  }

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

attr = gfc_expr_attr (fptr);

if (!attr.pointer)
  {
    gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
 &fptr->where);
    return false;
  }

if (fptr->ts.type == BT_CLASS)
  {
    gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
 &fptr->where);
    return false;
  }

if (gfc_is_coindexed (fptr))
  {
    gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
 "coindexed", &fptr->where);
    return false;
  }

if (fptr->rank == 0 && shape)
  {
    gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
 "FPTR", &fptr->where);
    return false;
  }
else if (fptr->rank && !shape)
  {
    gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
 "FPTR at %L", &fptr->where);
    return false;
  }

if (shape && !rank_check (shape, 2, 1))
  return false;

if (shape && !type_check (shape, 2, BT_INTEGER))
  return false;

if (shape)
  {
    mpz_t size;
    if (gfc_array_size (shape, &size))
{
 if (mpz_cmp_ui (size, fptr->rank)(__builtin_constant_p (fptr->rank) && (fptr->rank
) == 0 ? ((size)->_mp_size < 0 ? -1 : (size)->_mp_size
 > 0) : __gmpz_cmp_ui (size,fptr->rank)) != 0)
   {
     mpz_clear__gmpz_clear (size);
     gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
	"size as the RANK of FPTR", &shape->where);
     return false;
   }
 mpz_clear__gmpz_clear (size);
}
  }

if (fptr->ts.type == BT_CLASS)
  {
    gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
    return false;
  }

if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true))
  return gfc_notify_std (GFC_STD_F2018(1<<9), "Noninteroperable array FPTR "
	   "at %L to C_F_POINTER: %s", &fptr->where, msg);

return true;
5452}


5455bool
5456gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
5457{
symbol_attribute attr;

if (cptr->ts.type != BT_DERIVED
    || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
    || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
  {
    gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
 "type TYPE(C_FUNPTR)", &cptr->where);
    return false;
  }

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

attr = gfc_expr_attr (fptr);

if (!attr.proc_pointer)
  {
    gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
 "pointer", &fptr->where);
    return false;
  }

if (gfc_is_coindexed (fptr))
  {
    gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
 "coindexed", &fptr->where);
    return false;
  }

if (!attr.is_bind_c)
  return gfc_notify_std (GFC_STD_F2018(1<<9), "Noninteroperable procedure "
	   "pointer at %L to C_F_PROCPOINTER", &fptr->where);

return true;
5493}


5496bool
5497gfc_check_c_funloc (gfc_expr *x)
5498{
symbol_attribute attr;

if (gfc_is_coindexed (x))
  {
    gfc_error ("Argument X at %L to C_FUNLOC shall not be "
 "coindexed", &x->where);
    return false;
  }

attr = gfc_expr_attr (x);

if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
    && x->symtree->n.sym == x->symtree->n.sym->result)
  for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
    if (x->symtree->n.sym == ns->proc_name)
{
 gfc_error ("Function result %qs at %L is invalid as X argument "
     "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
 return false;
}

if (attr.flavor != FL_PROCEDURE)
  {
    gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
 "or a procedure pointer", &x->where);
    return false;
  }

if (!attr.is_bind_c)
  return gfc_notify_std (GFC_STD_F2018(1<<9), "Noninteroperable procedure "
	   "at %L to C_FUNLOC", &x->where);
return true;
5531}


5534bool
5535gfc_check_c_loc (gfc_expr *x)
5536{
symbol_attribute attr;
const char *msg;

if (gfc_is_coindexed (x))
  {
    gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
    return false;
  }

if (x->ts.type == BT_CLASS)
  {
    gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
 &x->where);
    return false;
  }

attr = gfc_expr_attr (x);

if (!attr.pointer
    && (x->expr_type != EXPR_VARIABLE || !attr.target
 || attr.flavor == FL_PARAMETER))
  {
    gfc_error ("Argument X at %L to C_LOC shall have either "
 "the POINTER or the TARGET attribute", &x->where);
    return false;
  }

if (x->ts.type == BT_CHARACTER
    && gfc_var_strlen (x) == 0)
  {
    gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
 "string", &x->where);
    return false;
  }

if (!is_c_interoperable (x, &msg, true, false))
  {
    if (x->ts.type == BT_CLASS)
{
 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
     &x->where);
 return false;
}

    if (x->rank
 && !gfc_notify_std (GFC_STD_F2018(1<<9),
	      "Noninteroperable array at %L as"
	      " argument to C_LOC: %s", &x->where, msg))
 return false;
  }
else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008(1<<7)))
  {
    gfc_array_ref *ar = gfc_find_array_ref (x);

    if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
 && !attr.allocatable
 && !gfc_notify_std (GFC_STD_F2008(1<<7),
	      "Array of interoperable type at %L "
	      "to C_LOC which is nonallocatable and neither "
	      "assumed size nor explicit size", &x->where))
return false;
    else if (ar->type != AR_FULL
      && !gfc_notify_std (GFC_STD_F2008(1<<7), "Array section at %L "
		   "to C_LOC", &x->where))
return false;
  }

return true;
5605}


5608bool
5609gfc_check_sleep_sub (gfc_expr *seconds)
5610{
if (!type_check (seconds, 0, BT_INTEGER))
  return false;

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

return true;
5618}

5620bool
5621gfc_check_sngl (gfc_expr *a)
5622{
if (!type_check (a, 0, BT_REAL))
  return false;

if ((a->ts.kind != gfc_default_double_kind)
    && !gfc_notify_std (GFC_STD_GNU(1<<5), "non double precision "
	  "REAL argument to %s intrinsic at %L",
	  gfc_current_intrinsic, &a->where))
  return false;

return true;
5633}

5635bool
5636gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
5637{
if (gfc_invalid_null_arg (source))
  return false;

if (source->rank >= GFC_MAX_DIMENSIONS15)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must be less "
 "than rank %d", gfc_current_intrinsic_arg[0]->name,
 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS15);

    return false;
  }

if (dim == NULL__null)
  return false;

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

/* dim_rank_check() does not apply here.  */
if (dim
    && dim->expr_type == EXPR_CONSTANT
    && (mpz_cmp_ui (dim->value.integer, 1)(__builtin_constant_p (1) && (1) == 0 ? ((dim->value
.integer)->_mp_size < 0 ? -1 : (dim->value.integer)->
_mp_size > 0) : __gmpz_cmp_ui (dim->value.integer,1)) < 0
 || mpz_cmp_ui (dim->value.integer, source->rank + 1)(__builtin_constant_p (source->rank + 1) && (source
->rank + 1) == 0 ? ((dim->value.integer)->_mp_size <
? -1 : (dim->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
 (dim->value.integer,source->rank + 1)) > 0))
  {
    gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
 "dimension index", gfc_current_intrinsic_arg[1]->name,
 gfc_current_intrinsic, &dim->where);
    return false;
  }

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

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

return true;
5675}


5678/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
 functions).  */

5681bool
5682arg_strlen_is_zero (gfc_expr *c, int n)
5683{
if (gfc_var_strlen (c) == 0)
  {
    gfc_error ("%qs argument of %qs intrinsic at %L must have "
 "length at least 1", gfc_current_intrinsic_arg[n]->name,
 gfc_current_intrinsic, &c->where);
    return true;
  }
return false;
5692}

5694bool
5695gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
5696{
if (!type_check (unit, 0, BT_INTEGER))
  return false;

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

if (!type_check (c, 1, BT_CHARACTER))
  return false;
if (!kind_value_check (c, 1, gfc_default_character_kind))
  return false;
if (strcmp (gfc_current_intrinsic, "fgetc") == 0
    && !variable_check (c, 1, false))
  return false;
if (arg_strlen_is_zero (c, 1))
  return false;

if (status == NULL__null)
  return true;

if (!type_check (status, 2, BT_INTEGER)
    || !kind_value_check (status, 2, gfc_default_integer_kind)
    || !scalar_check (status, 2)
    || !variable_check (status, 2, false))
  return false;

return true;
5723}


5726bool
5727gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
5728{
return gfc_check_fgetputc_sub (unit, c, NULL__null);
5730}


5733bool
5734gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
5735{
if (!type_check (c, 0, BT_CHARACTER))
  return false;
if (!kind_value_check (c, 0, gfc_default_character_kind))
  return false;
if (strcmp (gfc_current_intrinsic, "fget") == 0
    && !variable_check (c, 0, false))
  return false;
if (arg_strlen_is_zero (c, 0))
  return false;

if (status == NULL__null)
  return true;

if (!type_check (status, 1, BT_INTEGER)
    || !kind_value_check (status, 1, gfc_default_integer_kind)
    || !scalar_check (status, 1)
    || !variable_check (status, 1, false))
  return false;

return true;
5756}


5759bool
5760gfc_check_fgetput (gfc_expr *c)
5761{
return gfc_check_fgetput_sub (c, NULL__null);
5763}


5766bool
5767gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
5768{
if (!type_check (unit, 0, BT_INTEGER))
  return false;

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

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

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

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

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

if (status == NULL__null)
  return true;

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

if (!kind_value_check (status, 3, 4))
  return false;

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

return true;
5800}



5804bool
5805gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
5806{
if (!type_check (unit, 0, BT_INTEGER))
  return false;

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

if (!type_check (array, 1, BT_INTEGER)
    || !kind_value_check (unit, 0, gfc_default_integer_kind))
  return false;

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

return true;
5821}


5824bool
5825gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
5826{
if (!type_check (unit, 0, BT_INTEGER))
  return false;

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

if (!type_check (array, 1, BT_INTEGER)
    || !kind_value_check (array, 1, gfc_default_integer_kind))
  return false;

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

if (status == NULL__null)
  return true;

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

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

return true;
5851}


5854bool
5855gfc_check_ftell (gfc_expr *unit)
5856{
if (!type_check (unit, 0, BT_INTEGER))
  return false;

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

return true;
5864}


5867bool
5868gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
5869{
if (!type_check (unit, 0, BT_INTEGER))
  return false;

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

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

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

return true;
5883}


5886bool
5887gfc_check_stat (gfc_expr *name, gfc_expr *array)
5888{
if (!type_check (name, 0, BT_CHARACTER))
  return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
  return false;

if (!type_check (array, 1, BT_INTEGER)
    || !kind_value_check (array, 1, gfc_default_integer_kind))
  return false;

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

return true;
5902}


5905bool
5906gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
5907{
if (!type_check (name, 0, BT_CHARACTER))
  return false;
if (!kind_value_check (name, 0, gfc_default_character_kind))
  return false;

if (!type_check (array, 1, BT_INTEGER)
    || !kind_value_check (array, 1, gfc_default_integer_kind))
  return false;

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

if (status == NULL__null)
  return true;

if (!type_check (status, 2, BT_INTEGER)
    || !kind_value_check (array, 1, gfc_default_integer_kind))
  return false;

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

return true;
5931}


5934bool
5935gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
5936{
mpz_t nelems;

if (flag_coarrayglobal_options.x_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 (sub->rank != 1)
  {
    gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
              gfc_current_intrinsic_arg[1]->name, &sub->where);
    return false;
  }

if (sub->ts.type != BT_INTEGER)
  {
    gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
 gfc_current_intrinsic_arg[1]->name, &sub->where);
    return false;
  }

if (gfc_array_size (sub, &nelems))
  {
    int corank = gfc_get_corank (coarray);

    if (mpz_cmp_ui (nelems, corank)(__builtin_constant_p (corank) && (corank) == 0 ? ((nelems
)->_mp_size < 0 ? -1 : (nelems)->_mp_size > 0) : __gmpz_cmp_ui
 (nelems,corank)) != 0)
{
 gfc_error ("The number of array elements of the SUB argument to "
     "IMAGE_INDEX at %L shall be %d (corank) not %d",
     &sub->where, corank, (int) mpz_get_si__gmpz_get_si (nelems));
 mpz_clear__gmpz_clear (nelems);
 return false;
}
    mpz_clear__gmpz_clear (nelems);
  }

return true;
5978}


5981bool
5982gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
5983{
if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
  {
    gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
    return false;
  }

if (distance)
  {
    if (!type_check (distance, 0, BT_INTEGER))
return false;

    if (!nonnegative_check ("DISTANCE", distance))
return false;

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

    if (!gfc_notify_std (GFC_STD_F2018(1<<9), "DISTANCE= argument to "
	   "NUM_IMAGES at %L", &distance->where))
return false;
  }

 if (failed)
  {
    if (!type_check (failed, 1, BT_LOGICAL))
return false;

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

    if (!gfc_notify_std (GFC_STD_F2018(1<<9), "FAILED= argument to "
	   "NUM_IMAGES at %L", &failed->where))
return false;
  }

return true;
6020}


6023bool
6024gfc_check_team_number (gfc_expr *team)
6025{
if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
  {
    gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
    return false;
  }

if (team)
  {
    if (team->ts.type != BT_DERIVED
 || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
 || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
{
  gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
  	      "shall be of type TEAM_TYPE", &team->where);
  return false;
}
  }
else
  return true;

return true;
6047}


6050bool
6051gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
6052{
if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE)
  {
    gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
    return false;
  }

if (coarray == NULL__null && dim == NULL__null && distance == NULL__null)
  return true;

if (dim != NULL__null && coarray == NULL__null)
  {
    gfc_error ("DIM argument without COARRAY argument not allowed for "
 "THIS_IMAGE intrinsic at %L", &dim->where);
    return false;
  }

if (distance && (coarray || dim))
  {
    gfc_error ("The DISTANCE argument may not be specified together with the "
 "COARRAY or DIM argument in intrinsic at %L",
 &distance->where);
    return false;
  }

/* Assume that we have "this_image (distance)".  */
if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
  {
    if (dim)
{
 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
     &coarray->where);
 return false;
}
    distance = coarray;
  }

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

    if (!nonnegative_check ("DISTANCE", distance))
return false;

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

    if (!gfc_notify_std (GFC_STD_F2018(1<<9), "DISTANCE= argument to "
	   "THIS_IMAGE at %L", &distance->where))
return false;

    return true;
  }

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

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

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

return true;
6120}

6122/* Calculate the sizes for transfer, used by gfc_check_transfer and also
 by gfc_simplify_transfer.  Return false if we cannot do so.  */

6125bool
6126gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
	      size_t *source_size, size_t *result_size,
	      size_t *result_length_p)
6129{
size_t result_elt_size;

if (source->expr_type == EXPR_FUNCTION)
  return false;

if (size && size->expr_type != EXPR_CONSTANT)
  return false;

/* Calculate the size of the source.  */
if (!gfc_target_expr_size (source, source_size))
  return false;

/* Determine the size of the element.  */
if (!gfc_element_size (mold, &result_elt_size))
  return false;

/* If the storage size of SOURCE is greater than zero and MOLD is an array,
 * a scalar with the type and type parameters of MOLD shall not have a
 * storage size equal to zero.
 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
 * If MOLD is an array and SIZE is absent, the result is an array and of
 * rank one. Its size is as small as possible such that its physical
 * representation is not shorter than that of SOURCE.
 * If SIZE is present, the result is an array of rank one and size SIZE.
 */
if (result_elt_size == 0 && *source_size > 0
    && (mold->expr_type == EXPR_ARRAY || mold->rank))
  {
    gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
 "array and shall not have storage size 0 when %<SOURCE%> "
 "argument has size greater than 0", &mold->where);
    return false;
  }

if (result_elt_size == 0 && *source_size == 0 && !size)
  {
    *result_size = 0;
    if (result_length_p)
*result_length_p = 0;
    return true;
  }

if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank))
    || size)
  {
    int result_length;

    if (size)
result_length = (size_t)mpz_get_ui__gmpz_get_ui (size->value.integer);
    else
{
 result_length = *source_size / result_elt_size;
 if (result_length * result_elt_size < *source_size)
   result_length += 1;
}

    *result_size = result_length * result_elt_size;
    if (result_length_p)
*result_length_p = result_length;
  }
else
  *result_size = result_elt_size;

return true;
6194}


6197bool
6198gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
6199{
size_t source_size;
size_t result_size;

if (gfc_invalid_null_arg (source))
  return false;

/* SOURCE shall be a scalar or array of any type.  */
if (source->ts.type == BT_PROCEDURE
    && source->symtree->n.sym->attr.subroutine == 1)
  {
    gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
               "must not be a %s", &source->where,
 gfc_basic_typename (source->ts.type));
    return false;
  }

if (source->ts.type == BT_BOZ && illegal_boz_arg (source))
  return false;

if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold))
  return false;

if (gfc_invalid_null_arg (mold))
  return false;

/* MOLD shall be a scalar or array of any type.  */
if (mold->ts.type == BT_PROCEDURE
    && mold->symtree->n.sym->attr.subroutine == 1)
  {
    gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
               "must not be a %s", &mold->where,
 gfc_basic_typename (mold->ts.type));
    return false;
  }

if (mold->ts.type == BT_HOLLERITH)
  {
    gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
               " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
    return false;
  }

/* SIZE (optional) shall be an integer scalar.  The corresponding actual
   argument shall not be an optional dummy argument.  */
if (size != NULL__null)
  {
    if (!type_check (size, 2, BT_INTEGER))
{
 if (size->ts.type == BT_BOZ)
   reset_boz (size);
 return false;
}

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

    if (!nonoptional_check (size, 2))
return false;
  }

if (!warn_surprisingglobal_options.x_warn_surprising)
  return true;

/* If we can't calculate the sizes, we cannot check any more.
   Return true for that case.  */

if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
		     &result_size, NULL__null))
  return true;

if (source_size < result_size)
  gfc_warning (OPT_Wsurprising,
 "Intrinsic TRANSFER at %L has partly undefined result: "
 "source size %ld < result size %ld", &source->where,
 (long) source_size, (long) result_size);

return true;
6277}


6280bool
6281gfc_check_transpose (gfc_expr *matrix)
6282{
if (!rank_check (matrix, 0, 2))
  return false;

return true;
6287}


6290bool
6291gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6292{
if (!array_check (array, 0))
  return false;

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

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

if (!kind_check (kind, 2, BT_INTEGER))
  return false;
if (kind && !gfc_notify_std (GFC_STD_F2003(1<<4), "%qs intrinsic "
	       "with KIND argument at %L",
	       gfc_current_intrinsic, &kind->where))
  return false;

return true;
6310}


6313bool
6314gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
6315{
if (flag_coarrayglobal_options.x_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__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;
6338}


6341