]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/check.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
arith.c (gfc_convert_integer, [...]): Move to ...
[thirdparty/gcc.git] / gcc / fortran / check.c
CommitLineData
6de9cd9a 1/* Check functions
a5544970 2 Copyright (C) 2002-2019 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Andy Vaught & Katherine Holcomb
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 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
d234d788 9Software Foundation; either version 3, or (at your option) any later
9fc4d79b 10version.
6de9cd9a 11
9fc4d79b
TS		 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.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
d234d788
NC		 18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
6de9cd9a
DN		 20
21
22/* These functions check to see if an argument list is compatible with
23 a particular intrinsic function or subroutine. Presence of
24 required arguments has already been established, the argument list
25 has been sorted into the right order and has NULL arguments in the
26 correct places for missing optional arguments. */
27
6de9cd9a
DN		 28#include "config.h"
29#include "system.h"
953bee7c 30#include "coretypes.h"
1916bcb5 31#include "options.h"
6de9cd9a
DN		 32#include "gfortran.h"
33#include "intrinsic.h"
b7e75771 34#include "constructor.h"
86dbed7d 35#include "target-memory.h"
6de9cd9a 36
8dc63166
SK		 37/* A BOZ literal constant can appear in a limited number of contexts.
38 gfc_invalid_boz() is a help function to simplify error/warning generation.
39 Note, gfortran accepts the nonstandard 'X' for 'Z' the nonstandard
40 suffix location. If -fallow-invalid-boz is used, then issue a warning;
41 otherwise issue an error. */
42
43bool
44gfc_invalid_boz (const char *msg, locus *loc)
45{
46 if (flag_allow_invalid_boz)
47 {
48 gfc_warning (0, msg, loc);
49 return false;
50 }
51
52 gfc_error (msg, loc);
53 return true;
54}
55
56
57/* Some precedures take two arguments such that both cannot be BOZ. */
58
59static bool
60boz_args_check(gfc_expr *i, gfc_expr *j)
61{
62 if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
63 {
64 gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ "
65 "literal constants", gfc_current_intrinsic, &i->where,
66 &j->where);
67 return false;
68
69 }
70
71 return true;
72}
73
74
75/* Check that a BOZ is a constant. */
76
77static bool
78is_boz_constant (gfc_expr *a)
79{
80 if (a->expr_type != EXPR_CONSTANT)
81 {
82 gfc_error ("Invalid use of BOZ literal constant at %L", &a->where);
83 return false;
84 }
85
86 return true;
87}
88
89
90/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real ()
91 converts the string into a REAL of the appropriate kind. The treatment
92 of the sign bit is processor dependent. */
93
94bool
95gfc_boz2real (gfc_expr *x, int kind)
96{
97 extern int gfc_max_integer_kind;
98 gfc_typespec ts;
99 int len;
100 char *buf, *str;
101
102 if (!is_boz_constant (x))
103 return false;
104
105 /* Determine the length of the required string. */
106 len = 8 * kind;
107 if (x->boz.rdx == 16) len /= 4;
108 if (x->boz.rdx == 8) len = len / 3 + 1;
109 buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */
110
111 if (x->boz.len >= len) /* Truncate if necessary. */
112 {
113 str = x->boz.str + (x->boz.len - len);
114 strcpy(buf, str);
115 }
116 else /* Copy and pad. */
117 {
118 memset (buf, 48, len);
119 str = buf + (len - x->boz.len);
120 strcpy (str, x->boz.str);
121 }
122
123 /* Need to adjust leading bits in an octal string. */
124 if (x->boz.rdx == 8)
125 {
126 /* Clear first bit. */
127 if (kind == 4 || kind == 10 || kind == 16)
128 {
129 if (buf[0] == '4')
130 buf[0] = '0';
131 else if (buf[0] == '5')
132 buf[0] = '1';
133 else if (buf[0] == '6')
134 buf[0] = '2';
135 else if (buf[0] == '7')
136 buf[0] = '3';
137 }
138 /* Clear first two bits. */
139 else
140 {
141 if (buf[0] == '4' || buf[0] == '6')
142 buf[0] = '0';
143 else if (buf[0] == '5' || buf[0] == '7')
144 buf[0] = '1';
145 }
146 }
147
148 /* Reset BOZ string to the truncated or padded version. */
149 free (x->boz.str);
150 x->boz.len = len;
151 x->boz.str = XCNEWVEC (char, len + 1);
152 strncpy (x->boz.str, buf, len);
153
154 /* Convert to widest possible integer. */
155 gfc_boz2int (x, gfc_max_integer_kind);
156 ts.type = BT_REAL;
157 ts.kind = kind;
158 if (!gfc_convert_boz (x, &ts))
159 {
160 gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where);
161 return false;
162 }
163
164 return true;
165}
166
167
168/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int ()
169 converts the string into an INTEGER of the appropriate kind. The
170 treatment of the sign bit is processor dependent. If the converted
171 value exceeds the range of the type, then wrap-around semantics are
172 applied. */
173
174bool
175gfc_boz2int (gfc_expr *x, int kind)
176{
177 int i, len;
178 char *buf, *str;
179 mpz_t tmp1;
180
181 if (!is_boz_constant (x))
182 return false;
183
184 i = gfc_validate_kind (BT_INTEGER, kind, false);
185 len = gfc_integer_kinds[i].bit_size;
186 if (x->boz.rdx == 16) len /= 4;
187 if (x->boz.rdx == 8) len = len / 3 + 1;
188 buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */
189
190 if (x->boz.len >= len) /* Truncate if necessary. */
191 {
192 str = x->boz.str + (x->boz.len - len);
193 strcpy(buf, str);
194 }
195 else /* Copy and pad. */
196 {
197 memset (buf, 48, len);
198 str = buf + (len - x->boz.len);
199 strcpy (str, x->boz.str);
200 }
201
202 /* Need to adjust leading bits in an octal string. */
203 if (x->boz.rdx == 8)
204 {
205 /* Clear first bit. */
206 if (kind == 1 || kind == 4 || kind == 16)
207 {
208 if (buf[0] == '4')
209 buf[0] = '0';
210 else if (buf[0] == '5')
211 buf[0] = '1';
212 else if (buf[0] == '6')
213 buf[0] = '2';
214 else if (buf[0] == '7')
215 buf[0] = '3';
216 }
217 /* Clear first two bits. */
218 else
219 {
220 if (buf[0] == '4' || buf[0] == '6')
221 buf[0] = '0';
222 else if (buf[0] == '5' || buf[0] == '7')
223 buf[0] = '1';
224 }
225 }
226
227 /* Convert as-if unsigned integer. */
228 mpz_init (tmp1);
229 mpz_set_str (tmp1, buf, x->boz.rdx);
230
231 /* Check for wrap-around. */
232 if (mpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0)
233 {
234 mpz_t tmp2;
235 mpz_init (tmp2);
236 mpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1);
237 mpz_mod (tmp1, tmp1, tmp2);
238 mpz_sub (tmp1, tmp1, tmp2);
239 mpz_clear (tmp2);
240 }
241
242 /* Clear boz info. */
243 x->boz.rdx = 0;
244 x->boz.len = 0;
245 free (x->boz.str);
246
247 mpz_init (x->value.integer);
248 mpz_set (x->value.integer, tmp1);
249 x->ts.type = BT_INTEGER;
250 x->ts.kind = kind;
251 mpz_clear (tmp1);
252
253 return true;
254}
255
6de9cd9a 256
7ab88654
TB		 257/* Make sure an expression is a scalar. */
258
524af0d6 259static bool
7ab88654
TB		 260scalar_check (gfc_expr *e, int n)
261{
262 if (e->rank == 0)
524af0d6 263 return true;
7ab88654 264
c4100eae 265 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
c4aa95f8
JW		 266 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
267 &e->where);
7ab88654 268
524af0d6 269 return false;
7ab88654
TB		 270}
271
272
6de9cd9a
DN		 273/* Check the type of an expression. */
274
524af0d6 275static bool
65f8144a 276type_check (gfc_expr *e, int n, bt type)
6de9cd9a 277{
6de9cd9a 278 if (e->ts.type == type)
524af0d6 279 return true;
6de9cd9a 280
c4100eae 281 gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
c4aa95f8
JW		 282 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
283 &e->where, gfc_basic_typename (type));
6de9cd9a 284
524af0d6 285 return false;
6de9cd9a
DN		 286}
287
288
289/* Check that the expression is a numeric type. */
290
524af0d6 291static bool
65f8144a 292numeric_check (gfc_expr *e, int n)
6de9cd9a 293{
1b70aaad
SK		 294 /* Users sometime use a subroutine designator as an actual argument to
295 an intrinsic subprogram that expects an argument with a numeric type. */
296 if (e->symtree && e->symtree->n.sym->attr.subroutine)
297 goto error;
298
6de9cd9a 299 if (gfc_numeric_ts (&e->ts))
524af0d6 300 return true;
6de9cd9a 301
909a3e38
PT		 302 /* If the expression has not got a type, check if its namespace can
303 offer a default type. */
fc2655fb 304 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
909a3e38 305 && e->symtree->n.sym->ts.type == BT_UNKNOWN
524af0d6 306 && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns)
909a3e38
PT		 307 && gfc_numeric_ts (&e->symtree->n.sym->ts))
308 {
309 e->ts = e->symtree->n.sym->ts;
524af0d6 310 return true;
909a3e38
PT		 311 }
312
1b70aaad
SK		 313error:
314
315 gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type",
c4aa95f8
JW		 316 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
317 &e->where);
6de9cd9a 318
524af0d6 319 return false;
6de9cd9a
DN		 320}
321
322
323/* Check that an expression is integer or real. */
324
524af0d6 325static bool
65f8144a 326int_or_real_check (gfc_expr *e, int n)
6de9cd9a 327{
6de9cd9a
DN		 328 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
329 {
c4100eae 330 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
c4aa95f8 331 "or REAL", gfc_current_intrinsic_arg[n]->name,
65f8144a 332 gfc_current_intrinsic, &e->where);
524af0d6 333 return false;
6de9cd9a
DN		 334 }
335
524af0d6 336 return true;
6de9cd9a
DN		 337}
338
ddc9995b
TK		 339/* Check that an expression is integer or real; allow character for
340 F2003 or later. */
341
342static bool
343int_or_real_or_char_check_f2003 (gfc_expr *e, int n)
344{
345 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
346 {
347 if (e->ts.type == BT_CHARACTER)
348 return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for "
349 "%qs argument of %qs intrinsic at %L",
350 gfc_current_intrinsic_arg[n]->name,
351 gfc_current_intrinsic, &e->where);
352 else
353 {
354 if (gfc_option.allow_std & GFC_STD_F2003)
355 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
356 "or REAL or CHARACTER",
357 gfc_current_intrinsic_arg[n]->name,
358 gfc_current_intrinsic, &e->where);
359 else
360 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
361 "or REAL", gfc_current_intrinsic_arg[n]->name,
362 gfc_current_intrinsic, &e->where);
363 }
364 return false;
365 }
366
367 return true;
368}
369
01ce9e31
TK		 370/* Check that an expression is an intrinsic type. */
371static bool
372intrinsic_type_check (gfc_expr *e, int n)
373{
374 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
375 && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER
376 && e->ts.type != BT_LOGICAL)
377 {
378 gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
379 gfc_current_intrinsic_arg[n]->name,
380 gfc_current_intrinsic, &e->where);
381 return false;
382 }
383 return true;
384}
6de9cd9a 385
985aff9c
PB		 386/* Check that an expression is real or complex. */
387
524af0d6 388static bool
65f8144a 389real_or_complex_check (gfc_expr *e, int n)
985aff9c
PB		 390{
391 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
392 {
c4100eae 393 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
c4aa95f8
JW		 394 "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
395 gfc_current_intrinsic, &e->where);
524af0d6 396 return false;
c4aa95f8
JW		 397 }
398
524af0d6 399 return true;
c4aa95f8
JW		 400}
401
402
403/* Check that an expression is INTEGER or PROCEDURE. */
404
524af0d6 405static bool
c4aa95f8
JW		 406int_or_proc_check (gfc_expr *e, int n)
407{
408 if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
409 {
c4100eae 410 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
c4aa95f8 411 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
65f8144a 412 gfc_current_intrinsic, &e->where);
524af0d6 413 return false;
985aff9c
PB		 414 }
415
524af0d6 416 return true;
985aff9c
PB		 417}
418
419
6de9cd9a
DN		 420/* Check that the expression is an optional constant integer
421 and that it specifies a valid kind for that type. */
422
524af0d6 423static bool
65f8144a 424kind_check (gfc_expr *k, int n, bt type)
6de9cd9a
DN		 425{
426 int kind;
427
428 if (k == NULL)
524af0d6 429 return true;
6de9cd9a 430
524af0d6
JB		 431 if (!type_check (k, n, BT_INTEGER))
432 return false;
6de9cd9a 433
524af0d6
JB		 434 if (!scalar_check (k, n))
435 return false;
7ab88654 436
524af0d6 437 if (!gfc_check_init_expr (k))
6de9cd9a 438 {
c4100eae 439 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
c4aa95f8 440 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
65f8144a 441 &k->where);
524af0d6 442 return false;
6de9cd9a
DN		 443 }
444
51f03c6b 445 if (gfc_extract_int (k, &kind)
e7a2d5fb 446 || gfc_validate_kind (type, kind, true) < 0)
6de9cd9a
DN		 447 {
448 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
449 &k->where);
524af0d6 450 return false;
6de9cd9a
DN		 451 }
452
524af0d6 453 return true;
6de9cd9a
DN		 454}
455
456
457/* Make sure the expression is a double precision real. */
458
524af0d6 459static bool
65f8144a 460double_check (gfc_expr *d, int n)
6de9cd9a 461{
524af0d6
JB		 462 if (!type_check (d, n, BT_REAL))
463 return false;
6de9cd9a 464
9d64df18 465 if (d->ts.kind != gfc_default_double_kind)
6de9cd9a 466 {
c4100eae 467 gfc_error ("%qs argument of %qs intrinsic at %L must be double "
c4aa95f8 468 "precision", gfc_current_intrinsic_arg[n]->name,
65f8144a 469 gfc_current_intrinsic, &d->where);
524af0d6 470 return false;
6de9cd9a
DN		 471 }
472
524af0d6 473 return true;
6de9cd9a
DN		 474}
475
476
524af0d6 477static bool
c4aa95f8
JW		 478coarray_check (gfc_expr *e, int n)
479{
fac665b2
TB		 480 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
481 && CLASS_DATA (e)->attr.codimension
482 && CLASS_DATA (e)->as->corank)
483 {
484 gfc_add_class_array_ref (e);
524af0d6 485 return true;
fac665b2
TB		 486 }
487
266edc7e 488 if (!gfc_is_coarray (e))
c4aa95f8 489 {
c4100eae 490 gfc_error ("Expected coarray variable as %qs argument to the %s "
c4aa95f8
JW		 491 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
492 gfc_current_intrinsic, &e->where);
524af0d6 493 return false;
c4aa95f8
JW		 494 }
495
524af0d6 496 return true;
8b704316 497}
c4aa95f8
JW		 498
499
6de9cd9a
DN		 500/* Make sure the expression is a logical array. */
501
524af0d6 502static bool
65f8144a 503logical_array_check (gfc_expr *array, int n)
6de9cd9a 504{
6de9cd9a
DN		 505 if (array->ts.type != BT_LOGICAL || array->rank == 0)
506 {
c4100eae 507 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
c4aa95f8
JW		 508 "array", gfc_current_intrinsic_arg[n]->name,
509 gfc_current_intrinsic, &array->where);
524af0d6 510 return false;
6de9cd9a
DN		 511 }
512
524af0d6 513 return true;
6de9cd9a
DN		 514}
515
516
517/* Make sure an expression is an array. */
518
524af0d6 519static bool
65f8144a 520array_check (gfc_expr *e, int n)
6de9cd9a 521{
fac665b2 522 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
c49ea23d
PT		 523 && CLASS_DATA (e)->attr.dimension
524 && CLASS_DATA (e)->as->rank)
525 {
526 gfc_add_class_array_ref (e);
524af0d6 527 return true;
c49ea23d
PT		 528 }
529
52880d11 530 if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
524af0d6 531 return true;
6de9cd9a 532
c4100eae 533 gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
c4aa95f8
JW		 534 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
535 &e->where);
6de9cd9a 536
524af0d6 537 return false;
6de9cd9a
DN		 538}
539
540
289e52fd
SK		 541/* If expr is a constant, then check to ensure that it is greater than
542 of equal to zero. */
543
524af0d6 544static bool
289e52fd
SK		 545nonnegative_check (const char *arg, gfc_expr *expr)
546{
547 int i;
548
549 if (expr->expr_type == EXPR_CONSTANT)
550 {
551 gfc_extract_int (expr, &i);
552 if (i < 0)
553 {
c4100eae 554 gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
524af0d6 555 return false;
289e52fd
SK		 556 }
557 }
558
524af0d6 559 return true;
289e52fd
SK		 560}
561
562
ef78bc3c
AV		 563/* If expr is a constant, then check to ensure that it is greater than zero. */
564
565static bool
566positive_check (int n, gfc_expr *expr)
567{
568 int i;
569
570 if (expr->expr_type == EXPR_CONSTANT)
571 {
572 gfc_extract_int (expr, &i);
573 if (i <= 0)
574 {
575 gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
576 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
577 &expr->where);
578 return false;
579 }
580 }
581
582 return true;
583}
584
585
289e52fd 586/* If expr2 is constant, then check that the value is less than
88a95a11 587 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */
289e52fd 588
524af0d6 589static bool
289e52fd 590less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
88a95a11 591 gfc_expr *expr2, bool or_equal)
289e52fd
SK		 592{
593 int i2, i3;
594
595 if (expr2->expr_type == EXPR_CONSTANT)
596 {
597 gfc_extract_int (expr2, &i2);
598 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
8b704316 599
0019028b
SK		 600 /* For ISHFT[C], check that |shift| <= bit_size(i). */
601 if (arg2 == NULL)
602 {
603 if (i2 < 0)
604 i2 = -i2;
605
606 if (i2 > gfc_integer_kinds[i3].bit_size)
607 {
608 gfc_error ("The absolute value of SHIFT at %L must be less "
c4100eae 609 "than or equal to BIT_SIZE(%qs)",
0019028b 610 &expr2->where, arg1);
524af0d6 611 return false;
0019028b
SK		 612 }
613 }
614
88a95a11 615 if (or_equal)
289e52fd 616 {
88a95a11
FXC		 617 if (i2 > gfc_integer_kinds[i3].bit_size)
618 {
c4100eae
MLI		 619 gfc_error ("%qs at %L must be less than "
620 "or equal to BIT_SIZE(%qs)",
88a95a11 621 arg2, &expr2->where, arg1);
524af0d6 622 return false;
88a95a11
FXC		 623 }
624 }
625 else
626 {
627 if (i2 >= gfc_integer_kinds[i3].bit_size)
628 {
c4100eae 629 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
88a95a11 630 arg2, &expr2->where, arg1);
524af0d6 631 return false;
88a95a11 632 }
289e52fd
SK		 633 }
634 }
635
524af0d6 636 return true;
289e52fd
SK		 637}
638
639
88a95a11
FXC		 640/* If expr is constant, then check that the value is less than or equal
641 to the bit_size of the kind k. */
642
524af0d6 643static bool
88a95a11
FXC		 644less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
645{
646 int i, val;
647
648 if (expr->expr_type != EXPR_CONSTANT)
524af0d6 649 return true;
8b704316 650
88a95a11
FXC		 651 i = gfc_validate_kind (BT_INTEGER, k, false);
652 gfc_extract_int (expr, &val);
653
654 if (val > gfc_integer_kinds[i].bit_size)
655 {
c4100eae 656 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
88a95a11 657 "INTEGER(KIND=%d)", arg, &expr->where, k);
524af0d6 658 return false;
88a95a11
FXC		 659 }
660
524af0d6 661 return true;
88a95a11
FXC		 662}
663
664
289e52fd
SK		 665/* If expr2 and expr3 are constants, then check that the value is less than
666 or equal to bit_size(expr1). */
667
524af0d6 668static bool
289e52fd
SK		 669less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
670 gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
671{
672 int i2, i3;
673
674 if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
675 {
676 gfc_extract_int (expr2, &i2);
677 gfc_extract_int (expr3, &i3);
678 i2 += i3;
679 i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
680 if (i2 > gfc_integer_kinds[i3].bit_size)
681 {
a4d9b221 682 gfc_error ("%<%s + %s%> at %L must be less than or equal "
c4100eae 683 "to BIT_SIZE(%qs)",
289e52fd 684 arg2, arg3, &expr2->where, arg1);
524af0d6 685 return false;
289e52fd
SK		 686 }
687 }
688
524af0d6 689 return true;
289e52fd
SK		 690}
691
f5bf550c 692/* Make sure two expressions have the same type. */
6de9cd9a 693
524af0d6 694static bool
6e307219 695same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
6de9cd9a 696{
57905c2b
PT		 697 gfc_typespec *ets = &e->ts;
698 gfc_typespec *fts = &f->ts;
699
6e307219
PT		 700 if (assoc)
701 {
702 /* Procedure pointer component expressions have the type of the interface
703 procedure. If they are being tested for association with a procedure
704 pointer (ie. not a component), the type of the procedure must be
705 determined. */
706 if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
707 ets = &e->symtree->n.sym->ts;
708 if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
709 fts = &f->symtree->n.sym->ts;
710 }
57905c2b
PT		 711
712 if (gfc_compare_types (ets, fts))
524af0d6 713 return true;
6de9cd9a 714
c4100eae
MLI		 715 gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
716 "and kind as %qs", gfc_current_intrinsic_arg[m]->name,
c4aa95f8
JW		 717 gfc_current_intrinsic, &f->where,
718 gfc_current_intrinsic_arg[n]->name);
65f8144a 719
524af0d6 720 return false;
6de9cd9a
DN		 721}
722
723
724/* Make sure that an expression has a certain (nonzero) rank. */
725
524af0d6 726static bool
65f8144a 727rank_check (gfc_expr *e, int n, int rank)
6de9cd9a 728{
6de9cd9a 729 if (e->rank == rank)
524af0d6 730 return true;
6de9cd9a 731
c4100eae 732 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
c4aa95f8 733 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
4c93c95a 734 &e->where, rank);
65f8144a 735
524af0d6 736 return false;
6de9cd9a
DN		 737}
738
739
740/* Make sure a variable expression is not an optional dummy argument. */
741
524af0d6 742static bool
65f8144a 743nonoptional_check (gfc_expr *e, int n)
6de9cd9a 744{
6de9cd9a
DN		 745 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
746 {
c4100eae 747 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
c4aa95f8 748 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
6de9cd9a 749 &e->where);
6de9cd9a
DN		 750 }
751
752 /* TODO: Recursive check on nonoptional variables? */
753
524af0d6 754 return true;
6de9cd9a
DN		 755}
756
757
c4aa95f8
JW		 758/* Check for ALLOCATABLE attribute. */
759
524af0d6 760static bool
c4aa95f8
JW		 761allocatable_check (gfc_expr *e, int n)
762{
763 symbol_attribute attr;
764
765 attr = gfc_variable_attr (e, NULL);
aa271860 766 if (!attr.allocatable || attr.associate_var)
c4aa95f8 767 {
c4100eae 768 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
c4aa95f8
JW		 769 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
770 &e->where);
524af0d6 771 return false;
c4aa95f8
JW		 772 }
773
524af0d6 774 return true;
c4aa95f8
JW		 775}
776
777
6de9cd9a
DN		 778/* Check that an expression has a particular kind. */
779
524af0d6 780static bool
65f8144a 781kind_value_check (gfc_expr *e, int n, int k)
6de9cd9a 782{
6de9cd9a 783 if (e->ts.kind == k)
524af0d6 784 return true;
6de9cd9a 785
c4100eae 786 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
c4aa95f8 787 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
4c93c95a 788 &e->where, k);
65f8144a 789
524af0d6 790 return false;
6de9cd9a
DN		 791}
792
793
794/* Make sure an expression is a variable. */
795
524af0d6 796static bool
11746b92 797variable_check (gfc_expr *e, int n, bool allow_proc)
6de9cd9a 798{
6de9cd9a 799 if (e->expr_type == EXPR_VARIABLE
c4aa95f8
JW		 800 && e->symtree->n.sym->attr.intent == INTENT_IN
801 && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
802 || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
6de9cd9a 803 {
f9fcedbd
TB		 804 gfc_ref *ref;
805 bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
806 && CLASS_DATA (e->symtree->n.sym)
807 ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
808 : e->symtree->n.sym->attr.pointer;
809
810 for (ref = e->ref; ref; ref = ref->next)
811 {
812 if (pointer && ref->type == REF_COMPONENT)
813 break;
814 if (ref->type == REF_COMPONENT
815 && ((ref->u.c.component->ts.type == BT_CLASS
816 && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
817 || (ref->u.c.component->ts.type != BT_CLASS
818 && ref->u.c.component->attr.pointer)))
819 break;
8b704316 820 }
f9fcedbd
TB		 821
822 if (!ref)
823 {
c4100eae 824 gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
f9fcedbd
TB		 825 "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
826 gfc_current_intrinsic, &e->where);
524af0d6 827 return false;
f9fcedbd 828 }
6de9cd9a
DN		 829 }
830
11746b92
TB		 831 if (e->expr_type == EXPR_VARIABLE
832 && e->symtree->n.sym->attr.flavor != FL_PARAMETER
04803728 833 && (allow_proc || !e->symtree->n.sym->attr.function))
524af0d6 834 return true;
c4aa95f8 835
04803728
TB		 836 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function
837 && e->symtree->n.sym == e->symtree->n.sym->result)
838 {
839 gfc_namespace *ns;
840 for (ns = gfc_current_ns; ns; ns = ns->parent)
841 if (ns->proc_name == e->symtree->n.sym)
524af0d6 842 return true;
04803728
TB		 843 }
844
c4100eae 845 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
c4aa95f8 846 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
6de9cd9a 847
524af0d6 848 return false;
6de9cd9a
DN		 849}
850
851
852/* Check the common DIM parameter for correctness. */
853
524af0d6 854static bool
7ab88654 855dim_check (gfc_expr *dim, int n, bool optional)
6de9cd9a 856{
7ab88654 857 if (dim == NULL)
524af0d6 858 return true;
6de9cd9a 859
524af0d6
JB		 860 if (!type_check (dim, n, BT_INTEGER))
861 return false;
6de9cd9a 862
524af0d6
JB		 863 if (!scalar_check (dim, n))
864 return false;
6de9cd9a 865
524af0d6
JB		 866 if (!optional && !nonoptional_check (dim, n))
867 return false;
ce99d594 868
524af0d6 869 return true;
6de9cd9a
DN		 870}
871
872
64f002ed
TB		 873/* If a coarray DIM parameter is a constant, make sure that it is greater than
874 zero and less than or equal to the corank of the given array. */
875
524af0d6 876static bool
64f002ed
TB		 877dim_corank_check (gfc_expr *dim, gfc_expr *array)
878{
64f002ed
TB		 879 int corank;
880
881 gcc_assert (array->expr_type == EXPR_VARIABLE);
882
883 if (dim->expr_type != EXPR_CONSTANT)
524af0d6 884 return true;
8b704316 885
c49ea23d 886 if (array->ts.type == BT_CLASS)
524af0d6 887 return true;
64f002ed 888
66b23e93 889 corank = gfc_get_corank (array);
64f002ed
TB		 890
891 if (mpz_cmp_ui (dim->value.integer, 1) < 0
892 || mpz_cmp_ui (dim->value.integer, corank) > 0)
893 {
a4d9b221 894 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
64f002ed
TB		 895 "codimension index", gfc_current_intrinsic, &dim->where);
896
524af0d6 897 return false;
64f002ed
TB		 898 }
899
524af0d6 900 return true;
64f002ed
TB		 901}
902
903
6de9cd9a
DN		 904/* If a DIM parameter is a constant, make sure that it is greater than
905 zero and less than or equal to the rank of the given array. If
906 allow_assumed is zero then dim must be less than the rank of the array
907 for assumed size arrays. */
908
524af0d6 909static bool
65f8144a 910dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
6de9cd9a
DN		 911{
912 gfc_array_ref *ar;
913 int rank;
914
ca8a8795 915 if (dim == NULL)
524af0d6 916 return true;
ca8a8795 917
7114ab45 918 if (dim->expr_type != EXPR_CONSTANT)
524af0d6 919 return true;
6de9cd9a 920
7114ab45
TK		 921 if (array->expr_type == EXPR_FUNCTION && array->value.function.isym
922 && array->value.function.isym->id == GFC_ISYM_SPREAD)
923 rank = array->rank + 1;
924 else
925 rank = array->rank;
926
c62c6622
TB		 927 /* Assumed-rank array. */
928 if (rank == -1)
929 rank = GFC_MAX_DIMENSIONS;
930
f8df0eb8
DF		 931 if (array->expr_type == EXPR_VARIABLE)
932 {
933 ar = gfc_find_array_ref (array);
934 if (ar->as->type == AS_ASSUMED_SIZE
935 && !allow_assumed
936 && ar->type != AR_ELEMENT
937 && ar->type != AR_SECTION)
938 rank--;
939 }
6de9cd9a
DN		 940
941 if (mpz_cmp_ui (dim->value.integer, 1) < 0
942 || mpz_cmp_ui (dim->value.integer, rank) > 0)
943 {
a4d9b221 944 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
6de9cd9a
DN		 945 "dimension index", gfc_current_intrinsic, &dim->where);
946
524af0d6 947 return false;
6de9cd9a
DN		 948 }
949
524af0d6 950 return true;
6de9cd9a
DN		 951}
952
65f8144a 953
a8999235
TK		 954/* Compare the size of a along dimension ai with the size of b along
955 dimension bi, returning 0 if they are known not to be identical,
956 and 1 if they are identical, or if this cannot be determined. */
957
958static int
959identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
960{
961 mpz_t a_size, b_size;
962 int ret;
963
964 gcc_assert (a->rank > ai);
965 gcc_assert (b->rank > bi);
966
967 ret = 1;
968
524af0d6 969 if (gfc_array_dimen_size (a, ai, &a_size))
a8999235 970 {
524af0d6 971 if (gfc_array_dimen_size (b, bi, &b_size))
a8999235
TK		 972 {
973 if (mpz_cmp (a_size, b_size) != 0)
974 ret = 0;
8b704316 975
a8999235
TK		 976 mpz_clear (b_size);
977 }
978 mpz_clear (a_size);
979 }
980 return ret;
981}
6de9cd9a 982
07818af4
TK		 983/* Calculate the length of a character variable, including substrings.
984 Strip away parentheses if necessary. Return -1 if no length could
985 be determined. */
986
987static long
988gfc_var_strlen (const gfc_expr *a)
989{
990 gfc_ref *ra;
991
992 while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
993 a = a->value.op.op1;
994
995 for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
996 ;
997
998 if (ra)
999 {
1000 long start_a, end_a;
1001
cadddfdd
TB		 1002 if (!ra->u.ss.end)
1003 return -1;
1004
1005 if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT)
07818af4
TK		 1006 && ra->u.ss.end->expr_type == EXPR_CONSTANT)
1007 {
cadddfdd
TB		 1008 start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer)
1009 : 1;
07818af4 1010 end_a = mpz_get_si (ra->u.ss.end->value.integer);
cadddfdd 1011 return (end_a < start_a) ? 0 : end_a - start_a + 1;
07818af4 1012 }
cadddfdd
TB		 1013 else if (ra->u.ss.start
1014 && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
07818af4
TK		 1015 return 1;
1016 else
1017 return -1;
1018 }
1019
1020 if (a->ts.u.cl && a->ts.u.cl->length
1021 && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1022 return mpz_get_si (a->ts.u.cl->length->value.integer);
1023 else if (a->expr_type == EXPR_CONSTANT
1024 && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
1025 return a->value.character.length;
1026 else
1027 return -1;
1028
1029}
65f8144a 1030
90d31126 1031/* Check whether two character expressions have the same length;
524af0d6
JB		 1032 returns true if they have or if the length cannot be determined,
1033 otherwise return false and raise a gfc_error. */
90d31126 1034
524af0d6 1035bool
fb5bc08b 1036gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
90d31126
TB		 1037{
1038 long len_a, len_b;
90d31126 1039
07818af4
TK		 1040 len_a = gfc_var_strlen(a);
1041 len_b = gfc_var_strlen(b);
90d31126 1042
07818af4 1043 if (len_a == -1 || len_b == -1 || len_a == len_b)
524af0d6 1044 return true;
07818af4
TK		 1045 else
1046 {
1047 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
1048 len_a, len_b, name, &a->where);
524af0d6 1049 return false;
07818af4 1050 }
90d31126
TB		 1051}
1052
1053
6de9cd9a
DN		 1054/***** Check functions *****/
1055
1056/* Check subroutine suitable for intrinsics taking a real argument and
1057 a kind argument for the result. */
1058
524af0d6 1059static bool
65f8144a 1060check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
6de9cd9a 1061{
524af0d6
JB		 1062 if (!type_check (a, 0, BT_REAL))
1063 return false;
1064 if (!kind_check (kind, 1, type))
1065 return false;
6de9cd9a 1066
524af0d6 1067 return true;
6de9cd9a
DN		 1068}
1069
65f8144a 1070
6de9cd9a
DN		 1071/* Check subroutine suitable for ceiling, floor and nint. */
1072
524af0d6 1073bool
65f8144a 1074gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
6de9cd9a 1075{
6de9cd9a
DN		 1076 return check_a_kind (a, kind, BT_INTEGER);
1077}
1078
65f8144a 1079
6de9cd9a
DN		 1080/* Check subroutine suitable for aint, anint. */
1081
524af0d6 1082bool
65f8144a 1083gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
6de9cd9a 1084{
6de9cd9a
DN		 1085 return check_a_kind (a, kind, BT_REAL);
1086}
1087
65f8144a 1088
524af0d6 1089bool
65f8144a 1090gfc_check_abs (gfc_expr *a)
6de9cd9a 1091{
524af0d6
JB		 1092 if (!numeric_check (a, 0))
1093 return false;
6de9cd9a 1094
524af0d6 1095 return true;
6de9cd9a
DN		 1096}
1097
65f8144a 1098
524af0d6 1099bool
719e72fb 1100gfc_check_achar (gfc_expr *a, gfc_expr *kind)
332e7efe 1101{
8dc63166
SK		 1102 if (a->ts.type == BT_BOZ)
1103 {
1104 if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
1105 "ACHAR intrinsic subprogram", &a->where))
1106 return false;
1107
1108 if (!gfc_boz2int (a, gfc_default_integer_kind))
1109 return false;
1110 }
1111
524af0d6
JB		 1112 if (!type_check (a, 0, BT_INTEGER))
1113 return false;
8dc63166 1114
524af0d6
JB		 1115 if (!kind_check (kind, 1, BT_CHARACTER))
1116 return false;
332e7efe 1117
524af0d6 1118 return true;
332e7efe
SK		 1119}
1120
6de9cd9a 1121
524af0d6 1122bool
65f8144a 1123gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
a119fc1c 1124{
524af0d6
JB		 1125 if (!type_check (name, 0, BT_CHARACTER)
1126 || !scalar_check (name, 0))
1127 return false;
1128 if (!kind_value_check (name, 0, gfc_default_character_kind))
1129 return false;
a119fc1c 1130
524af0d6
JB		 1131 if (!type_check (mode, 1, BT_CHARACTER)
1132 || !scalar_check (mode, 1))
1133 return false;
1134 if (!kind_value_check (mode, 1, gfc_default_character_kind))
1135 return false;
a119fc1c 1136
524af0d6 1137 return true;
a119fc1c
FXC		 1138}
1139
1140
524af0d6 1141bool
65f8144a 1142gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
6de9cd9a 1143{
524af0d6
JB		 1144 if (!logical_array_check (mask, 0))
1145 return false;
6de9cd9a 1146
524af0d6
JB		 1147 if (!dim_check (dim, 1, false))
1148 return false;
6de9cd9a 1149
524af0d6
JB		 1150 if (!dim_rank_check (dim, mask, 0))
1151 return false;
a16d978f 1152
524af0d6 1153 return true;
6de9cd9a
DN		 1154}
1155
1156
524af0d6 1157bool
65f8144a 1158gfc_check_allocated (gfc_expr *array)
6de9cd9a 1159{
ba85c8c3
AV		 1160 /* Tests on allocated components of coarrays need to detour the check to
1161 argument of the _caf_get. */
1162 if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION
1163 && array->value.function.isym
1164 && array->value.function.isym->id == GFC_ISYM_CAF_GET)
1165 {
1166 array = array->value.function.actual->expr;
1167 if (!array->ref)
1168 return false;
1169 }
1170
524af0d6
JB		 1171 if (!variable_check (array, 0, false))
1172 return false;
1173 if (!allocatable_check (array, 0))
1174 return false;
8b704316 1175
524af0d6 1176 return true;
6de9cd9a
DN		 1177}
1178
1179
1180/* Common check function where the first argument must be real or
1181 integer and the second argument must be the same as the first. */
1182
524af0d6 1183bool
65f8144a 1184gfc_check_a_p (gfc_expr *a, gfc_expr *p)
6de9cd9a 1185{
524af0d6
JB		 1186 if (!int_or_real_check (a, 0))
1187 return false;
6de9cd9a 1188
991bb832
FXC		 1189 if (a->ts.type != p->ts.type)
1190 {
c4100eae 1191 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
c4aa95f8
JW		 1192 "have the same type", gfc_current_intrinsic_arg[0]->name,
1193 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
65f8144a 1194 &p->where);
524af0d6 1195 return false;
991bb832
FXC		 1196 }
1197
1198 if (a->ts.kind != p->ts.kind)
1199 {
c7f587bd 1200 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
524af0d6
JB		 1201 &p->where))
1202 return false;
991bb832 1203 }
6de9cd9a 1204
524af0d6 1205 return true;
6de9cd9a
DN		 1206}
1207
1208
524af0d6 1209bool
15ead859
JD		 1210gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
1211{
524af0d6
JB		 1212 if (!double_check (x, 0) || !double_check (y, 1))
1213 return false;
15ead859 1214
524af0d6 1215 return true;
15ead859
JD		 1216}
1217
1218
524af0d6 1219bool
65f8144a 1220gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
6de9cd9a 1221{
8fb74da4 1222 symbol_attribute attr1, attr2;
6de9cd9a 1223 int i;
524af0d6 1224 bool t;
6690a9e0
PT		 1225 locus *where;
1226
1227 where = &pointer->where;
6de9cd9a 1228
5fabac29 1229 if (pointer->expr_type == EXPR_NULL)
6690a9e0 1230 goto null_arg;
5fabac29
JW		 1231
1232 attr1 = gfc_expr_attr (pointer);
6de9cd9a 1233
8fb74da4 1234 if (!attr1.pointer && !attr1.proc_pointer)
6de9cd9a 1235 {
c4100eae 1236 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
c4aa95f8 1237 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4c93c95a 1238 &pointer->where);
524af0d6 1239 return false;
6de9cd9a
DN		 1240 }
1241
5aacb11e
TB		 1242 /* F2008, C1242. */
1243 if (attr1.pointer && gfc_is_coindexed (pointer))
1244 {
c4100eae 1245 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
0c133211 1246 "coindexed", gfc_current_intrinsic_arg[0]->name,
5aacb11e 1247 gfc_current_intrinsic, &pointer->where);
524af0d6 1248 return false;
5aacb11e
TB		 1249 }
1250
58c0774f 1251 /* Target argument is optional. */
6de9cd9a 1252 if (target == NULL)
524af0d6 1253 return true;
6de9cd9a 1254
6690a9e0 1255 where = &target->where;
6de9cd9a 1256 if (target->expr_type == EXPR_NULL)
6690a9e0 1257 goto null_arg;
6de9cd9a 1258
e6524a51
TB		 1259 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
1260 attr2 = gfc_expr_attr (target);
58c0774f 1261 else
476220e7 1262 {
c4100eae 1263 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
c4aa95f8
JW		 1264 "or target VARIABLE or FUNCTION",
1265 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1266 &target->where);
524af0d6 1267 return false;
476220e7 1268 }
58c0774f 1269
8fb74da4 1270 if (attr1.pointer && !attr2.pointer && !attr2.target)
6de9cd9a 1271 {
c4100eae 1272 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
c4aa95f8 1273 "or a TARGET", gfc_current_intrinsic_arg[1]->name,
4c93c95a 1274 gfc_current_intrinsic, &target->where);
524af0d6 1275 return false;
6de9cd9a
DN		 1276 }
1277
5aacb11e
TB		 1278 /* F2008, C1242. */
1279 if (attr1.pointer && gfc_is_coindexed (target))
1280 {
c4100eae 1281 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
0c133211 1282 "coindexed", gfc_current_intrinsic_arg[1]->name,
5aacb11e 1283 gfc_current_intrinsic, &target->where);
524af0d6 1284 return false;
5aacb11e
TB		 1285 }
1286
524af0d6 1287 t = true;
6e307219 1288 if (!same_type_check (pointer, 0, target, 1, true))
524af0d6
JB		 1289 t = false;
1290 if (!rank_check (target, 0, pointer->rank))
1291 t = false;
6de9cd9a
DN		 1292 if (target->rank > 0)
1293 {
1294 for (i = 0; i < target->rank; i++)
65f8144a
SK		 1295 if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1296 {
1297 gfc_error ("Array section with a vector subscript at %L shall not "
31043f6c 1298 "be the target of a pointer",
65f8144a 1299 &target->where);
524af0d6 1300 t = false;
65f8144a
SK		 1301 break;
1302 }
6de9cd9a
DN		 1303 }
1304 return t;
6690a9e0
PT		 1305
1306null_arg:
1307
1308 gfc_error ("NULL pointer at %L is not permitted as actual argument "
c4100eae 1309 "of %qs intrinsic function", where, gfc_current_intrinsic);
524af0d6 1310 return false;
6690a9e0 1311
6de9cd9a
DN		 1312}
1313
1314
524af0d6 1315bool
ddf67998
TB		 1316gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
1317{
58a9e3c4 1318 /* gfc_notify_std would be a waste of time as the return value
ddf67998
TB		 1319 is seemingly used only for the generic resolution. The error
1320 will be: Too many arguments. */
1321 if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
524af0d6 1322 return false;
ddf67998
TB		 1323
1324 return gfc_check_atan2 (y, x);
1325}
1326
1327
524af0d6 1328bool
65f8144a 1329gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
a1bab9ea 1330{
524af0d6
JB		 1331 if (!type_check (y, 0, BT_REAL))
1332 return false;
1333 if (!same_type_check (y, 0, x, 1))
1334 return false;
a1bab9ea 1335
524af0d6 1336 return true;
a1bab9ea
TS		 1337}
1338
27dfc9c4 1339
524af0d6 1340static bool
7f4aaf91
TB		 1341gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
1342 gfc_expr *stat, int stat_no)
da661a58 1343{
7f4aaf91
TB		 1344 if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no))
1345 return false;
b5116268 1346
da661a58
TB		 1347 if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
1348 && !(atom->ts.type == BT_LOGICAL
1349 && atom->ts.kind == gfc_atomic_logical_kind))
1350 {
1351 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1352 "integer of ATOMIC_INT_KIND or a logical of "
1353 "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
524af0d6 1354 return false;
da661a58
TB		 1355 }
1356
bc81b5ce 1357 if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom))
da661a58
TB		 1358 {
1359 gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
1360 "coarray or coindexed", &atom->where, gfc_current_intrinsic);
524af0d6 1361 return false;
da661a58
TB		 1362 }
1363
1364 if (atom->ts.type != value->ts.type)
1365 {
fea70c99
MLI		 1366 gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
1367 "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name,
7f4aaf91
TB		 1368 gfc_current_intrinsic, &value->where,
1369 gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
524af0d6 1370 return false;
da661a58
TB		 1371 }
1372
7f4aaf91
TB		 1373 if (stat != NULL)
1374 {
1375 if (!type_check (stat, stat_no, BT_INTEGER))
1376 return false;
1377 if (!scalar_check (stat, stat_no))
1378 return false;
1379 if (!variable_check (stat, stat_no, false))
1380 return false;
1381 if (!kind_value_check (stat, stat_no, gfc_default_integer_kind))
1382 return false;
1383
286f737c 1384 if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
7f4aaf91
TB		 1385 gfc_current_intrinsic, &stat->where))
1386 return false;
1387 }
1388
524af0d6 1389 return true;
da661a58
TB		 1390}
1391
1392
524af0d6 1393bool
7f4aaf91 1394gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
da661a58 1395{
b5116268
TB		 1396 if (atom->expr_type == EXPR_FUNCTION
1397 && atom->value.function.isym
1398 && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1399 atom = atom->value.function.actual->expr;
1400
524af0d6 1401 if (!gfc_check_vardef_context (atom, false, false, false, NULL))
da661a58
TB		 1402 {
1403 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1404 "definable", gfc_current_intrinsic, &atom->where);
524af0d6 1405 return false;
da661a58
TB		 1406 }
1407
7f4aaf91 1408 return gfc_check_atomic (atom, 0, value, 1, stat, 2);
da661a58
TB		 1409}
1410
1411
524af0d6 1412bool
7f4aaf91 1413gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
da661a58 1414{
7f4aaf91
TB		 1415 if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
1416 {
1417 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1418 "integer of ATOMIC_INT_KIND", &atom->where,
1419 gfc_current_intrinsic);
1420 return false;
1421 }
1422
1423 return gfc_check_atomic_def (atom, value, stat);
1424}
1425
1426
1427bool
1428gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
1429{
1430 if (atom->expr_type == EXPR_FUNCTION
1431 && atom->value.function.isym
1432 && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1433 atom = atom->value.function.actual->expr;
da661a58 1434
524af0d6 1435 if (!gfc_check_vardef_context (value, false, false, false, NULL))
da661a58
TB		 1436 {
1437 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
1438 "definable", gfc_current_intrinsic, &value->where);
524af0d6 1439 return false;
da661a58
TB		 1440 }
1441
7f4aaf91
TB		 1442 return gfc_check_atomic (atom, 1, value, 0, stat, 2);
1443}
1444
1445
ef78bc3c
AV		 1446bool
1447gfc_check_image_status (gfc_expr *image, gfc_expr *team)
1448{
1449 /* IMAGE has to be a positive, scalar integer. */
1450 if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0)
1451 || !positive_check (0, image))
1452 return false;
1453
1454 if (team)
1455 {
1456 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1457 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1458 &team->where);
1459 return false;
1460 }
1461 return true;
1462}
1463
1464
1465bool
1466gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
1467{
1468 if (team)
1469 {
1470 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1471 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1472 &team->where);
1473 return false;
1474 }
1475
1476 if (kind)
1477 {
1478 int k;
1479
1480 if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1)
1481 || !positive_check (1, kind))
1482 return false;
1483
1484 /* Get the kind, reporting error on non-constant or overflow. */
1485 gfc_current_locus = kind->where;
1486 if (gfc_extract_int (kind, &k, 1))
1487 return false;
1488 if (gfc_validate_kind (BT_INTEGER, k, true) == -1)
1489 {
1490 gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
1491 "valid integer kind", gfc_current_intrinsic_arg[1]->name,
1492 gfc_current_intrinsic, &kind->where);
1493 return false;
1494 }
1495 }
1496 return true;
1497}
1498
1499
f8862a1b
DR		 1500bool
1501gfc_check_get_team (gfc_expr *level)
1502{
1503 if (level)
1504 {
1505 gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
1506 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
1507 &level->where);
1508 return false;
1509 }
1510 return true;
1511}
1512
1513
7f4aaf91
TB		 1514bool
1515gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
1516 gfc_expr *new_val, gfc_expr *stat)
1517{
1518 if (atom->expr_type == EXPR_FUNCTION
1519 && atom->value.function.isym
1520 && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1521 atom = atom->value.function.actual->expr;
1522
1523 if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4))
1524 return false;
1525
1526 if (!scalar_check (old, 1) || !scalar_check (compare, 2))
1527 return false;
1528
1529 if (!same_type_check (atom, 0, old, 1))
1530 return false;
1531
1532 if (!same_type_check (atom, 0, compare, 2))
1533 return false;
1534
1535 if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1536 {
1537 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1538 "definable", gfc_current_intrinsic, &atom->where);
1539 return false;
1540 }
1541
1542 if (!gfc_check_vardef_context (old, false, false, false, NULL))
1543 {
1544 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1545 "definable", gfc_current_intrinsic, &old->where);
1546 return false;
1547 }
1548
1549 return true;
1550}
1551
5df445a2
TB		 1552bool
1553gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
1554{
1555 if (event->ts.type != BT_DERIVED
1556 || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
1557 || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
1558 {
1559 gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
1560 "shall be of type EVENT_TYPE", &event->where);
1561 return false;
1562 }
1563
1564 if (!scalar_check (event, 0))
1565 return false;
1566
1567 if (!gfc_check_vardef_context (count, false, false, false, NULL))
1568 {
1569 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1570 "shall be definable", &count->where);
1571 return false;
1572 }
1573
1574 if (!type_check (count, 1, BT_INTEGER))
1575 return false;
1576
1577 int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
1578 int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
1579
1580 if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
1581 {
1582 gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
1583 "shall have at least the range of the default integer",
1584 &count->where);
1585 return false;
1586 }
1587
1588 if (stat != NULL)
1589 {
1590 if (!type_check (stat, 2, BT_INTEGER))
1591 return false;
1592 if (!scalar_check (stat, 2))
1593 return false;
1594 if (!variable_check (stat, 2, false))
1595 return false;
1596
286f737c 1597 if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L",
5df445a2
TB		 1598 gfc_current_intrinsic, &stat->where))
1599 return false;
1600 }
1601
1602 return true;
1603}
1604
7f4aaf91
TB		 1605
1606bool
1607gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
1608 gfc_expr *stat)
1609{
1610 if (atom->expr_type == EXPR_FUNCTION
1611 && atom->value.function.isym
1612 && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
1613 atom = atom->value.function.actual->expr;
1614
1615 if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
1616 {
1617 gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
1618 "integer of ATOMIC_INT_KIND", &atom->where,
1619 gfc_current_intrinsic);
1620 return false;
1621 }
1622
1623 if (!gfc_check_atomic (atom, 0, value, 1, stat, 3))
1624 return false;
1625
1626 if (!scalar_check (old, 2))
1627 return false;
1628
1629 if (!same_type_check (atom, 0, old, 2))
1630 return false;
1631
1632 if (!gfc_check_vardef_context (atom, false, false, false, NULL))
1633 {
1634 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
1635 "definable", gfc_current_intrinsic, &atom->where);
1636 return false;
1637 }
1638
1639 if (!gfc_check_vardef_context (old, false, false, false, NULL))
1640 {
1641 gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
1642 "definable", gfc_current_intrinsic, &old->where);
1643 return false;
1644 }
1645
1646 return true;
da661a58
TB		 1647}
1648
1649
e8525382
SK		 1650/* BESJN and BESYN functions. */
1651
524af0d6 1652bool
65f8144a 1653gfc_check_besn (gfc_expr *n, gfc_expr *x)
e8525382 1654{
524af0d6
JB		 1655 if (!type_check (n, 0, BT_INTEGER))
1656 return false;
29698e0f
TB		 1657 if (n->expr_type == EXPR_CONSTANT)
1658 {
1659 int i;
1660 gfc_extract_int (n, &i);
524af0d6
JB		 1661 if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument "
1662 "N at %L", &n->where))
1663 return false;
29698e0f 1664 }
e8525382 1665
524af0d6
JB		 1666 if (!type_check (x, 1, BT_REAL))
1667 return false;
e8525382 1668
524af0d6 1669 return true;
e8525382
SK		 1670}
1671
1672
29698e0f
TB		 1673/* Transformational version of the Bessel JN and YN functions. */
1674
524af0d6 1675bool
29698e0f
TB		 1676gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
1677{
524af0d6
JB		 1678 if (!type_check (n1, 0, BT_INTEGER))
1679 return false;
1680 if (!scalar_check (n1, 0))
1681 return false;
1682 if (!nonnegative_check ("N1", n1))
1683 return false;
1684
1685 if (!type_check (n2, 1, BT_INTEGER))
1686 return false;
1687 if (!scalar_check (n2, 1))
1688 return false;
1689 if (!nonnegative_check ("N2", n2))
1690 return false;
1691
1692 if (!type_check (x, 2, BT_REAL))
1693 return false;
1694 if (!scalar_check (x, 2))
1695 return false;
29698e0f 1696
524af0d6 1697 return true;
29698e0f
TB		 1698}
1699
1700
524af0d6 1701bool
88a95a11
FXC		 1702gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
1703{
8dc63166
SK		 1704 extern int gfc_max_integer_kind;
1705
1706 /* If i and j are both BOZ, convert to widest INTEGER. */
1707 if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ)
1708 {
1709 if (!gfc_boz2int (i, gfc_max_integer_kind))
1710 return false;
1711 if (!gfc_boz2int (j, gfc_max_integer_kind))
1712 return false;
1713 }
1714
1715 /* If i is BOZ and j is integer, convert i to type of j. */
1716 if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
1717 && !gfc_boz2int (i, j->ts.kind))
1718 return false;
1719
1720 /* If j is BOZ and i is integer, convert j to type of i. */
1721 if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
1722 && !gfc_boz2int (j, i->ts.kind))
1723 return false;
1724
524af0d6
JB		 1725 if (!type_check (i, 0, BT_INTEGER))
1726 return false;
88a95a11 1727
524af0d6
JB		 1728 if (!type_check (j, 1, BT_INTEGER))
1729 return false;
88a95a11 1730
524af0d6 1731 return true;
88a95a11
FXC		 1732}
1733
1734
524af0d6 1735bool
289e52fd 1736gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
6de9cd9a 1737{
524af0d6
JB		 1738 if (!type_check (i, 0, BT_INTEGER))
1739 return false;
289e52fd 1740
524af0d6
JB		 1741 if (!type_check (pos, 1, BT_INTEGER))
1742 return false;
6de9cd9a 1743
524af0d6
JB		 1744 if (!nonnegative_check ("pos", pos))
1745 return false;
289e52fd 1746
524af0d6
JB		 1747 if (!less_than_bitsize1 ("i", i, "pos", pos, false))
1748 return false;
289e52fd 1749
524af0d6 1750 return true;
6de9cd9a
DN		 1751}
1752
1753
524af0d6 1754bool
65f8144a 1755gfc_check_char (gfc_expr *i, gfc_expr *kind)
6de9cd9a 1756{
8dc63166
SK		 1757 if (i->ts.type == BT_BOZ)
1758 {
1759 if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
1760 "CHAR intrinsic subprogram", &i->where))
1761 return false;
1762
1763 if (!gfc_boz2int (i, gfc_default_integer_kind))
1764 return false;
1765 }
1766
524af0d6
JB		 1767 if (!type_check (i, 0, BT_INTEGER))
1768 return false;
8dc63166 1769
524af0d6
JB		 1770 if (!kind_check (kind, 1, BT_CHARACTER))
1771 return false;
6de9cd9a 1772
524af0d6 1773 return true;
6de9cd9a
DN		 1774}
1775
1776
524af0d6 1777bool
65f8144a 1778gfc_check_chdir (gfc_expr *dir)
f77b6ca3 1779{
524af0d6
JB		 1780 if (!type_check (dir, 0, BT_CHARACTER))
1781 return false;
1782 if (!kind_value_check (dir, 0, gfc_default_character_kind))
1783 return false;
f77b6ca3 1784
524af0d6 1785 return true;
f77b6ca3
FXC		 1786}
1787
1788
524af0d6 1789bool
65f8144a 1790gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
f77b6ca3 1791{
524af0d6
JB		 1792 if (!type_check (dir, 0, BT_CHARACTER))
1793 return false;
1794 if (!kind_value_check (dir, 0, gfc_default_character_kind))
1795 return false;
f77b6ca3
FXC		 1796
1797 if (status == NULL)
524af0d6 1798 return true;
f77b6ca3 1799
524af0d6
JB		 1800 if (!type_check (status, 1, BT_INTEGER))
1801 return false;
1802 if (!scalar_check (status, 1))
1803 return false;
f77b6ca3 1804
524af0d6 1805 return true;
f77b6ca3
FXC		 1806}
1807
1808
524af0d6 1809bool
65f8144a 1810gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
a119fc1c 1811{
524af0d6
JB		 1812 if (!type_check (name, 0, BT_CHARACTER))
1813 return false;
1814 if (!kind_value_check (name, 0, gfc_default_character_kind))
1815 return false;
a119fc1c 1816
524af0d6
JB		 1817 if (!type_check (mode, 1, BT_CHARACTER))
1818 return false;
1819 if (!kind_value_check (mode, 1, gfc_default_character_kind))
1820 return false;
a119fc1c 1821
524af0d6 1822 return true;
a119fc1c
FXC		 1823}
1824
1825
524af0d6 1826bool
65f8144a 1827gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
a119fc1c 1828{
524af0d6
JB		 1829 if (!type_check (name, 0, BT_CHARACTER))
1830 return false;
1831 if (!kind_value_check (name, 0, gfc_default_character_kind))
1832 return false;
a119fc1c 1833
524af0d6
JB		 1834 if (!type_check (mode, 1, BT_CHARACTER))
1835 return false;
1836 if (!kind_value_check (mode, 1, gfc_default_character_kind))
1837 return false;
a119fc1c
FXC		 1838
1839 if (status == NULL)
524af0d6 1840 return true;
a119fc1c 1841
524af0d6
JB		 1842 if (!type_check (status, 2, BT_INTEGER))
1843 return false;
a119fc1c 1844
524af0d6
JB		 1845 if (!scalar_check (status, 2))
1846 return false;
a119fc1c 1847
524af0d6 1848 return true;
a119fc1c
FXC		 1849}
1850
1851
524af0d6 1852bool
65f8144a 1853gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
6de9cd9a 1854{
8dc63166
SK		 1855 int k;
1856
1857 /* Check kind first, because it may be needed in conversion of a BOZ. */
1858 if (kind)
1859 {
1860 if (!kind_check (kind, 2, BT_COMPLEX))
1861 return false;
1862 gfc_extract_int (kind, &k);
1863 }
1864 else
1865 k = gfc_default_complex_kind;
1866
1867 if (x->ts.type == BT_BOZ && !gfc_boz2real (x, k))
1868 return false;
1869
524af0d6
JB		 1870 if (!numeric_check (x, 0))
1871 return false;
6de9cd9a
DN		 1872
1873 if (y != NULL)
1874 {
8dc63166
SK		 1875 if (y->ts.type == BT_BOZ && !gfc_boz2real (y, k))
1876 return false;
1877
524af0d6
JB		 1878 if (!numeric_check (y, 1))
1879 return false;
6de9cd9a
DN		 1880
1881 if (x->ts.type == BT_COMPLEX)
1882 {
c4100eae 1883 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
a4d9b221 1884 "present if %<x%> is COMPLEX",
c4aa95f8
JW		 1885 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1886 &y->where);
524af0d6 1887 return false;
6de9cd9a 1888 }
20562de4
SK		 1889
1890 if (y->ts.type == BT_COMPLEX)
1891 {
c4100eae 1892 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
c4aa95f8
JW		 1893 "of either REAL or INTEGER",
1894 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
1895 &y->where);
524af0d6 1896 return false;
20562de4 1897 }
6de9cd9a
DN		 1898 }
1899
4daa149b 1900 if (!kind && warn_conversion
2e60cfaa 1901 && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind)
4daa149b
TB		 1902 gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
1903 "COMPLEX(%d) at %L might lose precision, consider using "
1904 "the KIND argument", gfc_typename (&x->ts),
1905 gfc_default_real_kind, &x->where);
1906 else if (y && !kind && warn_conversion
2e60cfaa 1907 && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind)
4daa149b
TB		 1908 gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind "
1909 "COMPLEX(%d) at %L might lose precision, consider using "
1910 "the KIND argument", gfc_typename (&y->ts),
1911 gfc_default_real_kind, &y->where);
524af0d6 1912 return true;
6de9cd9a
DN		 1913}
1914
1915
d62cf3df 1916static bool
a16ee379
TB		 1917check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
1918 gfc_expr *errmsg, bool co_reduce)
d62cf3df
TB		 1919{
1920 if (!variable_check (a, 0, false))
1921 return false;
1922
aa9ca5ca
TB		 1923 if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with "
1924 "INTENT(INOUT)"))
1925 return false;
1926
a16ee379 1927 /* Fortran 2008, 12.5.2.4, paragraph 18. */
aa9ca5ca
TB		 1928 if (gfc_has_vector_subscript (a))
1929 {
a4d9b221 1930 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
aa9ca5ca
TB		 1931 "subroutine %s shall not have a vector subscript",
1932 &a->where, gfc_current_intrinsic);
1933 return false;
1934 }
1935
229c5919
TB		 1936 if (gfc_is_coindexed (a))
1937 {
1938 gfc_error ("The A argument at %L to the intrinsic %s shall not be "
1939 "coindexed", &a->where, gfc_current_intrinsic);
1940 return false;
1941 }
1942
a16ee379 1943 if (image_idx != NULL)
d62cf3df 1944 {
a16ee379 1945 if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
d62cf3df 1946 return false;
a16ee379 1947 if (!scalar_check (image_idx, co_reduce ? 2 : 1))
d62cf3df
TB		 1948 return false;
1949 }
1950
1951 if (stat != NULL)
1952 {
a16ee379 1953 if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER))
d62cf3df 1954 return false;
a16ee379 1955 if (!scalar_check (stat, co_reduce ? 3 : 2))
d62cf3df 1956 return false;
a16ee379 1957 if (!variable_check (stat, co_reduce ? 3 : 2, false))
d62cf3df
TB		 1958 return false;
1959 if (stat->ts.kind != 4)
1960 {
1961 gfc_error ("The stat= argument at %L must be a kind=4 integer "
1962 "variable", &stat->where);
1963 return false;
1964 }
1965 }
1966
1967 if (errmsg != NULL)
1968 {
a16ee379 1969 if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER))
d62cf3df 1970 return false;
a16ee379 1971 if (!scalar_check (errmsg, co_reduce ? 4 : 3))
d62cf3df 1972 return false;
a16ee379 1973 if (!variable_check (errmsg, co_reduce ? 4 : 3, false))
d62cf3df
TB		 1974 return false;
1975 if (errmsg->ts.kind != 1)
1976 {
1977 gfc_error ("The errmsg= argument at %L must be a default-kind "
1978 "character variable", &errmsg->where);
1979 return false;
1980 }
1981 }
1982
f19626cf 1983 if (flag_coarray == GFC_FCOARRAY_NONE)
d62cf3df 1984 {
29e0597e
TB		 1985 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
1986 &a->where);
d62cf3df
TB		 1987 return false;
1988 }
1989
1990 return true;
1991}
1992
1993
a16ee379
TB		 1994bool
1995gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
1996 gfc_expr *errmsg)
1997{
1998 if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
1999 {
229c5919
TB		 2000 gfc_error ("Support for the A argument at %L which is polymorphic A "
2001 "argument or has allocatable components is not yet "
2002 "implemented", &a->where);
2003 return false;
a16ee379
TB		 2004 }
2005 return check_co_collective (a, source_image, stat, errmsg, false);
2006}
2007
2008
2009bool
2010gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
2011 gfc_expr *stat, gfc_expr *errmsg)
2012{
2013 symbol_attribute attr;
229c5919
TB		 2014 gfc_formal_arglist *formal;
2015 gfc_symbol *sym;
a16ee379
TB		 2016
2017 if (a->ts.type == BT_CLASS)
2018 {
229c5919
TB		 2019 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
2020 &a->where);
2021 return false;
a16ee379
TB		 2022 }
2023
2024 if (gfc_expr_attr (a).alloc_comp)
2025 {
229c5919
TB		 2026 gfc_error ("Support for the A argument at %L with allocatable components"
2027 " is not yet implemented", &a->where);
2028 return false;
a16ee379
TB		 2029 }
2030
229c5919
TB		 2031 if (!check_co_collective (a, result_image, stat, errmsg, true))
2032 return false;
2033
2034 if (!gfc_resolve_expr (op))
2035 return false;
2036
a16ee379
TB		 2037 attr = gfc_expr_attr (op);
2038 if (!attr.pure || !attr.function)
2039 {
229c5919
TB		 2040 gfc_error ("OPERATOR argument at %L must be a PURE function",
2041 &op->where);
2042 return false;
a16ee379
TB		 2043 }
2044
229c5919
TB		 2045 if (attr.intrinsic)
2046 {
2047 /* None of the intrinsics fulfills the criteria of taking two arguments,
2048 returning the same type and kind as the arguments and being permitted
2049 as actual argument. */
2050 gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE",
2051 op->symtree->n.sym->name, &op->where);
2052 return false;
2053 }
a16ee379 2054
229c5919
TB		 2055 if (gfc_is_proc_ptr_comp (op))
2056 {
2057 gfc_component *comp = gfc_get_proc_ptr_comp (op);
2058 sym = comp->ts.interface;
2059 }
2060 else
2061 sym = op->symtree->n.sym;
a16ee379 2062
229c5919
TB		 2063 formal = sym->formal;
2064
2065 if (!formal || !formal->next || formal->next->next)
2066 {
2067 gfc_error ("The function passed as OPERATOR at %L shall have two "
2068 "arguments", &op->where);
2069 return false;
2070 }
2071
2072 if (sym->result->ts.type == BT_UNKNOWN)
2073 gfc_set_default_type (sym->result, 0, NULL);
2074
2075 if (!gfc_compare_types (&a->ts, &sym->result->ts))
2076 {
5ce15f69 2077 gfc_error ("The A argument at %L has type %s but the function passed as "
229c5919
TB		 2078 "OPERATOR at %L returns %s",
2079 &a->where, gfc_typename (&a->ts), &op->where,
2080 gfc_typename (&sym->result->ts));
2081 return false;
2082 }
2083 if (!gfc_compare_types (&a->ts, &formal->sym->ts)
2084 || !gfc_compare_types (&a->ts, &formal->next->sym->ts))
2085 {
2086 gfc_error ("The function passed as OPERATOR at %L has arguments of type "
2087 "%s and %s but shall have type %s", &op->where,
2088 gfc_typename (&formal->sym->ts),
2089 gfc_typename (&formal->next->sym->ts), gfc_typename (&a->ts));
2090 return false;
2091 }
2092 if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
2093 || formal->next->sym->as || formal->sym->attr.allocatable
2094 || formal->next->sym->attr.allocatable || formal->sym->attr.pointer
2095 || formal->next->sym->attr.pointer)
2096 {
2097 gfc_error ("The function passed as OPERATOR at %L shall have scalar "
2098 "nonallocatable nonpointer arguments and return a "
2099 "nonallocatable nonpointer scalar", &op->where);
2100 return false;
2101 }
2102
2103 if (formal->sym->attr.value != formal->next->sym->attr.value)
2104 {
2105 gfc_error ("The function passed as OPERATOR at %L shall have the VALUE "
2106 "attribute either for none or both arguments", &op->where);
2107 return false;
2108 }
2109
2110 if (formal->sym->attr.target != formal->next->sym->attr.target)
2111 {
2112 gfc_error ("The function passed as OPERATOR at %L shall have the TARGET "
2113 "attribute either for none or both arguments", &op->where);
2114 return false;
2115 }
2116
2117 if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous)
2118 {
2119 gfc_error ("The function passed as OPERATOR at %L shall have the "
2120 "ASYNCHRONOUS attribute either for none or both arguments",
2121 &op->where);
2122 return false;
2123 }
2124
2125 if (formal->sym->attr.optional || formal->next->sym->attr.optional)
2126 {
2127 gfc_error ("The function passed as OPERATOR at %L shall not have the "
2128 "OPTIONAL attribute for either of the arguments", &op->where);
2129 return false;
2130 }
2131
2132 if (a->ts.type == BT_CHARACTER)
2133 {
2134 gfc_charlen *cl;
2135 unsigned long actual_size, formal_size1, formal_size2, result_size;
2136
2137 cl = a->ts.u.cl;
2138 actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2139 ? mpz_get_ui (cl->length->value.integer) : 0;
2140
2141 cl = formal->sym->ts.u.cl;
2142 formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2143 ? mpz_get_ui (cl->length->value.integer) : 0;
2144
2145 cl = formal->next->sym->ts.u.cl;
2146 formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2147 ? mpz_get_ui (cl->length->value.integer) : 0;
2148
2149 cl = sym->ts.u.cl;
2150 result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2151 ? mpz_get_ui (cl->length->value.integer) : 0;
2152
2153 if (actual_size
2154 && ((formal_size1 && actual_size != formal_size1)
2155 || (formal_size2 && actual_size != formal_size2)))
2156 {
fea70c99
MLI		 2157 gfc_error ("The character length of the A argument at %L and of the "
2158 "arguments of the OPERATOR at %L shall be the same",
229c5919
TB		 2159 &a->where, &op->where);
2160 return false;
2161 }
2162 if (actual_size && result_size && actual_size != result_size)
2163 {
fea70c99
MLI		 2164 gfc_error ("The character length of the A argument at %L and of the "
2165 "function result of the OPERATOR at %L shall be the same",
2166 &a->where, &op->where);
229c5919
TB		 2167 return false;
2168 }
2169 }
2170
2171 return true;
a16ee379
TB		 2172}
2173
2174
d62cf3df
TB		 2175bool
2176gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
2177 gfc_expr *errmsg)
2178{
2179 if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
2180 && a->ts.type != BT_CHARACTER)
2181 {
fea70c99
MLI		 2182 gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
2183 "integer, real or character",
2184 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
2185 &a->where);
d62cf3df
TB		 2186 return false;
2187 }
a16ee379 2188 return check_co_collective (a, result_image, stat, errmsg, false);
d62cf3df
TB		 2189}
2190
2191
2192bool
2193gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
2194 gfc_expr *errmsg)
2195{
2196 if (!numeric_check (a, 0))
2197 return false;
a16ee379 2198 return check_co_collective (a, result_image, stat, errmsg, false);
d62cf3df
TB		 2199}
2200
2201
524af0d6 2202bool
65f8144a 2203gfc_check_complex (gfc_expr *x, gfc_expr *y)
5d723e54 2204{
8dc63166
SK		 2205
2206 /* FIXME BOZ. What to do with complex? */
2207 if (!boz_args_check (x, y))
2208 return false;
2209
2210 if (x->ts.type == BT_BOZ)
2211 {
2212 if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
2213 "intrinsic subprogram", &x->where))
2214 return false;
2215 if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind))
2216 return false;
2217 if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind))
2218 return false;
2219 }
2220
2221 if (y->ts.type == BT_BOZ)
2222 {
2223 if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
2224 "intrinsic subprogram", &y->where))
2225 return false;
2226 if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind))
2227 return false;
2228 if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind))
2229 return false;
2230 }
2231
524af0d6
JB		 2232 if (!int_or_real_check (x, 0))
2233 return false;
2234 if (!scalar_check (x, 0))
2235 return false;
5d723e54 2236
524af0d6
JB		 2237 if (!int_or_real_check (y, 1))
2238 return false;
2239 if (!scalar_check (y, 1))
2240 return false;
5d723e54 2241
524af0d6 2242 return true;
5d723e54
FXC		 2243}
2244
2245
524af0d6 2246bool
5cda5098 2247gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
6de9cd9a 2248{
524af0d6
JB		 2249 if (!logical_array_check (mask, 0))
2250 return false;
2251 if (!dim_check (dim, 1, false))
2252 return false;
2253 if (!dim_rank_check (dim, mask, 0))
2254 return false;
2255 if (!kind_check (kind, 2, BT_INTEGER))
2256 return false;
a4d9b221 2257 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 2258 "with KIND argument at %L",
524af0d6
JB		 2259 gfc_current_intrinsic, &kind->where))
2260 return false;
6de9cd9a 2261
524af0d6 2262 return true;
6de9cd9a
DN		 2263}
2264
2265
524af0d6 2266bool
65f8144a 2267gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
6de9cd9a 2268{
524af0d6
JB		 2269 if (!array_check (array, 0))
2270 return false;
6de9cd9a 2271
524af0d6
JB		 2272 if (!type_check (shift, 1, BT_INTEGER))
2273 return false;
62ee27a4 2274
524af0d6
JB		 2275 if (!dim_check (dim, 2, true))
2276 return false;
ca8a8795 2277
524af0d6
JB		 2278 if (!dim_rank_check (dim, array, false))
2279 return false;
ca8a8795
DF		 2280
2281 if (array->rank == 1 || shift->rank == 0)
6de9cd9a 2282 {
524af0d6
JB		 2283 if (!scalar_check (shift, 1))
2284 return false;
6de9cd9a 2285 }
ca8a8795 2286 else if (shift->rank == array->rank - 1)
6de9cd9a 2287 {
ca8a8795
DF		 2288 int d;
2289 if (!dim)
2290 d = 1;
2291 else if (dim->expr_type == EXPR_CONSTANT)
2292 gfc_extract_int (dim, &d);
2293 else
2294 d = -1;
2295
2296 if (d > 0)
2297 {
2298 int i, j;
2299 for (i = 0, j = 0; i < array->rank; i++)
2300 if (i != d - 1)
2301 {
2302 if (!identical_dimen_shape (array, i, shift, j))
2303 {
c4100eae 2304 gfc_error ("%qs argument of %qs intrinsic at %L has "
ca8a8795 2305 "invalid shape in dimension %d (%ld/%ld)",
c4aa95f8 2306 gfc_current_intrinsic_arg[1]->name,
ca8a8795
DF		 2307 gfc_current_intrinsic, &shift->where, i + 1,
2308 mpz_get_si (array->shape[i]),
2309 mpz_get_si (shift->shape[j]));
524af0d6 2310 return false;
ca8a8795
DF		 2311 }
2312
2313 j += 1;
2314 }
2315 }
2316 }
2317 else
2318 {
c4100eae 2319 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
c4aa95f8 2320 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
ca8a8795 2321 gfc_current_intrinsic, &shift->where, array->rank - 1);
524af0d6 2322 return false;
6de9cd9a
DN		 2323 }
2324
524af0d6 2325 return true;
6de9cd9a
DN		 2326}
2327
2328
524af0d6 2329bool
65f8144a 2330gfc_check_ctime (gfc_expr *time)
35059811 2331{
524af0d6
JB		 2332 if (!scalar_check (time, 0))
2333 return false;
35059811 2334
524af0d6
JB		 2335 if (!type_check (time, 0, BT_INTEGER))
2336 return false;
35059811 2337
524af0d6 2338 return true;
35059811
FXC		 2339}
2340
2341
524af0d6 2342bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
15ead859 2343{
524af0d6
JB		 2344 if (!double_check (y, 0) || !double_check (x, 1))
2345 return false;
15ead859 2346
524af0d6 2347 return true;
15ead859
JD		 2348}
2349
524af0d6 2350bool
65f8144a 2351gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
6de9cd9a 2352{
8dc63166
SK		 2353 if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
2354 return false;
2355
524af0d6
JB		 2356 if (!numeric_check (x, 0))
2357 return false;
6de9cd9a
DN		 2358
2359 if (y != NULL)
2360 {
8dc63166
SK		 2361 if (y->ts.type == BT_BOZ && !gfc_boz2real (y, gfc_default_double_kind))
2362 return false;
2363
524af0d6
JB		 2364 if (!numeric_check (y, 1))
2365 return false;
6de9cd9a
DN		 2366
2367 if (x->ts.type == BT_COMPLEX)
2368 {
c4100eae 2369 gfc_error ("%qs argument of %qs intrinsic at %L must not be "
a4d9b221 2370 "present if %<x%> is COMPLEX",
c4aa95f8
JW		 2371 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2372 &y->where);
524af0d6 2373 return false;
6de9cd9a 2374 }
20562de4
SK		 2375
2376 if (y->ts.type == BT_COMPLEX)
2377 {
c4100eae 2378 gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
c4aa95f8
JW		 2379 "of either REAL or INTEGER",
2380 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2381 &y->where);
524af0d6 2382 return false;
20562de4 2383 }
6de9cd9a
DN		 2384 }
2385
524af0d6 2386 return true;
6de9cd9a
DN		 2387}
2388
2389
524af0d6 2390bool
65f8144a 2391gfc_check_dble (gfc_expr *x)
6de9cd9a 2392{
8dc63166
SK		 2393 if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
2394 return false;
2395
524af0d6
JB		 2396 if (!numeric_check (x, 0))
2397 return false;
6de9cd9a 2398
524af0d6 2399 return true;
6de9cd9a
DN		 2400}
2401
2402
524af0d6 2403bool
65f8144a 2404gfc_check_digits (gfc_expr *x)
6de9cd9a 2405{
524af0d6
JB		 2406 if (!int_or_real_check (x, 0))
2407 return false;
6de9cd9a 2408
524af0d6 2409 return true;
6de9cd9a
DN		 2410}
2411
2412
524af0d6 2413bool
65f8144a 2414gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
6de9cd9a 2415{
6de9cd9a
DN		 2416 switch (vector_a->ts.type)
2417 {
2418 case BT_LOGICAL:
524af0d6
JB		 2419 if (!type_check (vector_b, 1, BT_LOGICAL))
2420 return false;
6de9cd9a
DN		 2421 break;
2422
2423 case BT_INTEGER:
2424 case BT_REAL:
2425 case BT_COMPLEX:
524af0d6
JB		 2426 if (!numeric_check (vector_b, 1))
2427 return false;
6de9cd9a
DN		 2428 break;
2429
2430 default:
c4100eae 2431 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
c4aa95f8 2432 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
4c93c95a 2433 gfc_current_intrinsic, &vector_a->where);
524af0d6 2434 return false;
6de9cd9a
DN		 2435 }
2436
524af0d6
JB		 2437 if (!rank_check (vector_a, 0, 1))
2438 return false;
6de9cd9a 2439
524af0d6
JB		 2440 if (!rank_check (vector_b, 1, 1))
2441 return false;
6de9cd9a 2442
a8999235
TK		 2443 if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
2444 {
c4100eae 2445 gfc_error ("Different shape for arguments %qs and %qs at %L for "
a4d9b221
TB		 2446 "intrinsic %<dot_product%>",
2447 gfc_current_intrinsic_arg[0]->name,
c4aa95f8 2448 gfc_current_intrinsic_arg[1]->name, &vector_a->where);
524af0d6 2449 return false;
a8999235
TK		 2450 }
2451
524af0d6 2452 return true;
6de9cd9a
DN		 2453}
2454
2455
524af0d6 2456bool
15ead859
JD		 2457gfc_check_dprod (gfc_expr *x, gfc_expr *y)
2458{
524af0d6
JB		 2459 if (!type_check (x, 0, BT_REAL)
2460 || !type_check (y, 1, BT_REAL))
2461 return false;
15ead859
JD		 2462
2463 if (x->ts.kind != gfc_default_real_kind)
2464 {
c4100eae 2465 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
c4aa95f8 2466 "real", gfc_current_intrinsic_arg[0]->name,
15ead859 2467 gfc_current_intrinsic, &x->where);
524af0d6 2468 return false;
15ead859
JD		 2469 }
2470
2471 if (y->ts.kind != gfc_default_real_kind)
2472 {
c4100eae 2473 gfc_error ("%qs argument of %qs intrinsic at %L must be default "
c4aa95f8 2474 "real", gfc_current_intrinsic_arg[1]->name,
15ead859 2475 gfc_current_intrinsic, &y->where);
524af0d6 2476 return false;
15ead859
JD		 2477 }
2478
524af0d6 2479 return true;
15ead859
JD		 2480}
2481
8dc63166
SK		 2482bool
2483gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
89c1cf26 2484{
8dc63166
SK		 2485 /* i and j cannot both be BOZ literal constants. */
2486 if (!boz_args_check (i, j))
2487 return false;
89c1cf26 2488
8dc63166
SK		 2489 /* If i is BOZ and j is integer, convert i to type of j. */
2490 if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
2491 && !gfc_boz2int (i, j->ts.kind))
2492 return false;
89c1cf26 2493
8dc63166
SK		 2494 /* If j is BOZ and i is integer, convert j to type of i. */
2495 if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
2496 && !gfc_boz2int (j, i->ts.kind))
2497 return false;
89c1cf26 2498
524af0d6
JB		 2499 if (!type_check (i, 0, BT_INTEGER))
2500 return false;
88a95a11 2501
524af0d6
JB		 2502 if (!type_check (j, 1, BT_INTEGER))
2503 return false;
88a95a11 2504
8dc63166 2505 if (!same_type_check (i, 0, j, 1))
524af0d6 2506 return false;
88a95a11 2507
524af0d6
JB		 2508 if (!type_check (shift, 2, BT_INTEGER))
2509 return false;
88a95a11 2510
524af0d6
JB		 2511 if (!nonnegative_check ("SHIFT", shift))
2512 return false;
88a95a11 2513
8dc63166
SK		 2514 if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
2515 return false;
88a95a11 2516
524af0d6 2517 return true;
88a95a11
FXC		 2518}
2519
2520
524af0d6 2521bool
65f8144a
SK		 2522gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
2523 gfc_expr *dim)
6de9cd9a 2524{
fbd35ba1
TK		 2525 int d;
2526
524af0d6
JB		 2527 if (!array_check (array, 0))
2528 return false;
6de9cd9a 2529
524af0d6
JB		 2530 if (!type_check (shift, 1, BT_INTEGER))
2531 return false;
6de9cd9a 2532
524af0d6
JB		 2533 if (!dim_check (dim, 3, true))
2534 return false;
ca8a8795 2535
524af0d6
JB		 2536 if (!dim_rank_check (dim, array, false))
2537 return false;
ca8a8795 2538
fbd35ba1
TK		 2539 if (!dim)
2540 d = 1;
2541 else if (dim->expr_type == EXPR_CONSTANT)
2542 gfc_extract_int (dim, &d);
2543 else
2544 d = -1;
2545
ca8a8795 2546 if (array->rank == 1 || shift->rank == 0)
6de9cd9a 2547 {
524af0d6
JB		 2548 if (!scalar_check (shift, 1))
2549 return false;
6de9cd9a 2550 }
ca8a8795 2551 else if (shift->rank == array->rank - 1)
6de9cd9a 2552 {
ca8a8795
DF		 2553 if (d > 0)
2554 {
2555 int i, j;
2556 for (i = 0, j = 0; i < array->rank; i++)
2557 if (i != d - 1)
2558 {
2559 if (!identical_dimen_shape (array, i, shift, j))
2560 {
c4100eae 2561 gfc_error ("%qs argument of %qs intrinsic at %L has "
ca8a8795 2562 "invalid shape in dimension %d (%ld/%ld)",
c4aa95f8 2563 gfc_current_intrinsic_arg[1]->name,
ca8a8795
DF		 2564 gfc_current_intrinsic, &shift->where, i + 1,
2565 mpz_get_si (array->shape[i]),
2566 mpz_get_si (shift->shape[j]));
524af0d6 2567 return false;
ca8a8795
DF		 2568 }
2569
2570 j += 1;
2571 }
2572 }
2573 }
2574 else
2575 {
c4100eae 2576 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
c4aa95f8 2577 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
ca8a8795 2578 gfc_current_intrinsic, &shift->where, array->rank - 1);
524af0d6 2579 return false;
6de9cd9a
DN		 2580 }
2581
2582 if (boundary != NULL)
2583 {
524af0d6
JB		 2584 if (!same_type_check (array, 0, boundary, 2))
2585 return false;
6de9cd9a 2586
fbd35ba1
TK		 2587 /* Reject unequal string lengths and emit a better error message than
2588 gfc_check_same_strlen would. */
2589 if (array->ts.type == BT_CHARACTER)
2590 {
2591 ssize_t len_a, len_b;
2592
2593 len_a = gfc_var_strlen (array);
2594 len_b = gfc_var_strlen (boundary);
2595 if (len_a != -1 && len_b != -1 && len_a != len_b)
2596 {
2597 gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
2598 gfc_current_intrinsic_arg[2]->name,
2599 gfc_current_intrinsic_arg[0]->name,
2600 &boundary->where, gfc_current_intrinsic);
2601 return false;
2602 }
2603 }
f8862a1b 2604
ca8a8795 2605 if (array->rank == 1 || boundary->rank == 0)
d1a296c1 2606 {
524af0d6
JB		 2607 if (!scalar_check (boundary, 2))
2608 return false;
d1a296c1 2609 }
ca8a8795 2610 else if (boundary->rank == array->rank - 1)
d1a296c1 2611 {
fbd35ba1
TK		 2612 if (d > 0)
2613 {
2614 int i,j;
2615 for (i = 0, j = 0; i < array->rank; i++)
2616 {
2617 if (i != d - 1)
2618 {
2619 if (!identical_dimen_shape (array, i, boundary, j))
2620 {
2621 gfc_error ("%qs argument of %qs intrinsic at %L has "
2622 "invalid shape in dimension %d (%ld/%ld)",
2623 gfc_current_intrinsic_arg[2]->name,
2624 gfc_current_intrinsic, &shift->where, i+1,
2625 mpz_get_si (array->shape[i]),
2626 mpz_get_si (boundary->shape[j]));
2627 return false;
2628 }
2629 j += 1;
2630 }
2631 }
2632 }
d1a296c1 2633 }
ca8a8795 2634 else
d1a296c1 2635 {
c4100eae 2636 gfc_error ("%qs argument of intrinsic %qs at %L of must have "
c4aa95f8
JW		 2637 "rank %d or be a scalar",
2638 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
2639 &shift->where, array->rank - 1);
524af0d6 2640 return false;
d1a296c1 2641 }
6de9cd9a 2642 }
8987beac
TK		 2643 else
2644 {
2645 switch (array->ts.type)
2646 {
2647 case BT_INTEGER:
2648 case BT_LOGICAL:
2649 case BT_REAL:
2650 case BT_COMPLEX:
2651 case BT_CHARACTER:
2652 break;
f8862a1b 2653
8987beac
TK		 2654 default:
2655 gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs "
2656 "of type %qs", gfc_current_intrinsic_arg[2]->name,
2657 gfc_current_intrinsic, &array->where,
2658 gfc_current_intrinsic_arg[0]->name,
2659 gfc_typename (&array->ts));
2660 return false;
2661 }
2662 }
6de9cd9a 2663
524af0d6 2664 return true;
6de9cd9a
DN		 2665}
2666
8dc63166 2667
524af0d6 2668bool
c9018c71
DF		 2669gfc_check_float (gfc_expr *a)
2670{
8dc63166
SK		 2671 if (a->ts.type == BT_BOZ)
2672 {
2673 if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in the "
2674 "FLOAT intrinsic subprogram", &a->where))
2675 return false;
2676 if (!gfc_boz2int (a, gfc_default_integer_kind))
2677 return false;
2678 }
2679
524af0d6
JB		 2680 if (!type_check (a, 0, BT_INTEGER))
2681 return false;
c9018c71
DF		 2682
2683 if ((a->ts.kind != gfc_default_integer_kind)
524af0d6 2684 && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
c7f587bd 2685 "kind argument to %s intrinsic at %L",
524af0d6
JB		 2686 gfc_current_intrinsic, &a->where))
2687 return false;
c9018c71 2688
524af0d6 2689 return true;
c9018c71 2690}
6de9cd9a 2691
985aff9c
PB		 2692/* A single complex argument. */
2693
524af0d6 2694bool
65f8144a 2695gfc_check_fn_c (gfc_expr *a)
985aff9c 2696{
524af0d6
JB		 2697 if (!type_check (a, 0, BT_COMPLEX))
2698 return false;
985aff9c 2699
524af0d6 2700 return true;
985aff9c
PB		 2701}
2702
1b314f14 2703
985aff9c
PB		 2704/* A single real argument. */
2705
524af0d6 2706bool
65f8144a 2707gfc_check_fn_r (gfc_expr *a)
985aff9c 2708{
524af0d6
JB		 2709 if (!type_check (a, 0, BT_REAL))
2710 return false;
985aff9c 2711
524af0d6 2712 return true;
985aff9c
PB		 2713}
2714
15ead859
JD		 2715/* A single double argument. */
2716
524af0d6 2717bool
15ead859
JD		 2718gfc_check_fn_d (gfc_expr *a)
2719{
524af0d6
JB		 2720 if (!double_check (a, 0))
2721 return false;
15ead859 2722
524af0d6 2723 return true;
15ead859 2724}
985aff9c
PB		 2725
2726/* A single real or complex argument. */
2727
524af0d6 2728bool
65f8144a 2729gfc_check_fn_rc (gfc_expr *a)
985aff9c 2730{
524af0d6
JB		 2731 if (!real_or_complex_check (a, 0))
2732 return false;
985aff9c 2733
524af0d6 2734 return true;
985aff9c
PB		 2735}
2736
2737
524af0d6 2738bool
8d3681f9
TB		 2739gfc_check_fn_rc2008 (gfc_expr *a)
2740{
524af0d6
JB		 2741 if (!real_or_complex_check (a, 0))
2742 return false;
8d3681f9
TB		 2743
2744 if (a->ts.type == BT_COMPLEX
a4d9b221
TB		 2745 && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs "
2746 "of %qs intrinsic at %L",
2747 gfc_current_intrinsic_arg[0]->name,
524af0d6
JB		 2748 gfc_current_intrinsic, &a->where))
2749 return false;
8d3681f9 2750
524af0d6 2751 return true;
8d3681f9
TB		 2752}
2753
2754
524af0d6 2755bool
65f8144a 2756gfc_check_fnum (gfc_expr *unit)
df65f093 2757{
524af0d6
JB		 2758 if (!type_check (unit, 0, BT_INTEGER))
2759 return false;
df65f093 2760
524af0d6
JB		 2761 if (!scalar_check (unit, 0))
2762 return false;
df65f093 2763
524af0d6 2764 return true;
df65f093
SK		 2765}
2766
2767
524af0d6 2768bool
65f8144a 2769gfc_check_huge (gfc_expr *x)
6de9cd9a 2770{
524af0d6
JB		 2771 if (!int_or_real_check (x, 0))
2772 return false;
6de9cd9a 2773
524af0d6 2774 return true;
6de9cd9a
DN		 2775}
2776
2777
524af0d6 2778bool
f489fba1
FXC		 2779gfc_check_hypot (gfc_expr *x, gfc_expr *y)
2780{
524af0d6
JB		 2781 if (!type_check (x, 0, BT_REAL))
2782 return false;
2783 if (!same_type_check (x, 0, y, 1))
2784 return false;
f489fba1 2785
524af0d6 2786 return true;
f489fba1
FXC		 2787}
2788
2789
6de9cd9a
DN		 2790/* Check that the single argument is an integer. */
2791
524af0d6 2792bool
65f8144a 2793gfc_check_i (gfc_expr *i)
6de9cd9a 2794{
524af0d6
JB		 2795 if (!type_check (i, 0, BT_INTEGER))
2796 return false;
6de9cd9a 2797
524af0d6 2798 return true;
6de9cd9a
DN		 2799}
2800
2801
524af0d6 2802bool
89c1cf26 2803gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j)
6de9cd9a 2804{
8dc63166
SK		 2805 /* i and j cannot both be BOZ literal constants. */
2806 if (!boz_args_check (i, j))
524af0d6 2807 return false;
6de9cd9a 2808
8dc63166
SK		 2809 /* If i is BOZ and j is integer, convert i to type of j. */
2810 if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
2811 && !gfc_boz2int (i, j->ts.kind))
524af0d6 2812 return false;
6de9cd9a 2813
8dc63166
SK		 2814 /* If j is BOZ and i is integer, convert j to type of i. */
2815 if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
2816 && !gfc_boz2int (j, i->ts.kind))
2817 return false;
2818
2819 if (!type_check (i, 0, BT_INTEGER))
89c1cf26
SK		 2820 return false;
2821
8dc63166
SK		 2822 if (!type_check (j, 1, BT_INTEGER))
2823 return false;
89c1cf26 2824
c3d003d2
SK		 2825 if (i->ts.kind != j->ts.kind)
2826 {
89c1cf26
SK		 2827 gfc_error ("Arguments of %qs have different kind type parameters "
2828 "at %L", gfc_current_intrinsic, &i->where);
524af0d6 2829 return false;
c3d003d2
SK		 2830 }
2831
524af0d6 2832 return true;
6de9cd9a
DN		 2833}
2834
2835
524af0d6 2836bool
65f8144a 2837gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
6de9cd9a 2838{
524af0d6
JB		 2839 if (!type_check (i, 0, BT_INTEGER))
2840 return false;
c3d003d2 2841
524af0d6
JB		 2842 if (!type_check (pos, 1, BT_INTEGER))
2843 return false;
c3d003d2 2844
524af0d6
JB		 2845 if (!type_check (len, 2, BT_INTEGER))
2846 return false;
6de9cd9a 2847
524af0d6
JB		 2848 if (!nonnegative_check ("pos", pos))
2849 return false;
6de9cd9a 2850
524af0d6
JB		 2851 if (!nonnegative_check ("len", len))
2852 return false;
c3d003d2 2853
524af0d6
JB		 2854 if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len))
2855 return false;
6de9cd9a 2856
524af0d6 2857 return true;
6de9cd9a
DN		 2858}
2859
2860
524af0d6 2861bool
5cda5098 2862gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
860c8f3b
PB		 2863{
2864 int i;
2865
524af0d6
JB		 2866 if (!type_check (c, 0, BT_CHARACTER))
2867 return false;
860c8f3b 2868
524af0d6
JB		 2869 if (!kind_check (kind, 1, BT_INTEGER))
2870 return false;
5cda5098 2871
a4d9b221 2872 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 2873 "with KIND argument at %L",
524af0d6
JB		 2874 gfc_current_intrinsic, &kind->where))
2875 return false;
5cda5098 2876
78bd27f6 2877 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
860c8f3b
PB		 2878 {
2879 gfc_expr *start;
2880 gfc_expr *end;
2881 gfc_ref *ref;
2882
2883 /* Substring references don't have the charlength set. */
2884 ref = c->ref;
2885 while (ref && ref->type != REF_SUBSTRING)
2886 ref = ref->next;
2887
2888 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
2889
2890 if (!ref)
78bd27f6 2891 {
65f8144a 2892 /* Check that the argument is length one. Non-constant lengths
e2ae1407 2893 can't be checked here, so assume they are ok. */
bc21d315 2894 if (c->ts.u.cl && c->ts.u.cl->length)
78bd27f6
AP		 2895 {
2896 /* If we already have a length for this expression then use it. */
bc21d315 2897 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
524af0d6 2898 return true;
bc21d315 2899 i = mpz_get_si (c->ts.u.cl->length->value.integer);
78bd27f6 2900 }
8b704316 2901 else
524af0d6 2902 return true;
78bd27f6
AP		 2903 }
2904 else
2905 {
2906 start = ref->u.ss.start;
2907 end = ref->u.ss.end;
860c8f3b 2908
78bd27f6
AP		 2909 gcc_assert (start);
2910 if (end == NULL || end->expr_type != EXPR_CONSTANT
2911 || start->expr_type != EXPR_CONSTANT)
524af0d6 2912 return true;
860c8f3b 2913
78bd27f6 2914 i = mpz_get_si (end->value.integer) + 1
65f8144a 2915 - mpz_get_si (start->value.integer);
78bd27f6 2916 }
860c8f3b
PB		 2917 }
2918 else
524af0d6 2919 return true;
860c8f3b
PB		 2920
2921 if (i != 1)
2922 {
8b704316 2923 gfc_error ("Argument of %s at %L must be of length one",
860c8f3b 2924 gfc_current_intrinsic, &c->where);
524af0d6 2925 return false;
860c8f3b
PB		 2926 }
2927
524af0d6 2928 return true;
860c8f3b
PB		 2929}
2930
2931
524af0d6 2932bool
65f8144a 2933gfc_check_idnint (gfc_expr *a)
6de9cd9a 2934{
524af0d6
JB		 2935 if (!double_check (a, 0))
2936 return false;
6de9cd9a 2937
524af0d6 2938 return true;
6de9cd9a
DN		 2939}
2940
2941
524af0d6 2942bool
5cda5098
FXC		 2943gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
2944 gfc_expr *kind)
6de9cd9a 2945{
524af0d6
JB		 2946 if (!type_check (string, 0, BT_CHARACTER)
2947 || !type_check (substring, 1, BT_CHARACTER))
2948 return false;
6de9cd9a 2949
524af0d6
JB		 2950 if (back != NULL && !type_check (back, 2, BT_LOGICAL))
2951 return false;
6de9cd9a 2952
524af0d6
JB		 2953 if (!kind_check (kind, 3, BT_INTEGER))
2954 return false;
a4d9b221 2955 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 2956 "with KIND argument at %L",
524af0d6
JB		 2957 gfc_current_intrinsic, &kind->where))
2958 return false;
5cda5098 2959
6de9cd9a
DN		 2960 if (string->ts.kind != substring->ts.kind)
2961 {
c4100eae
MLI		 2962 gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
2963 "kind as %qs", gfc_current_intrinsic_arg[1]->name,
4c93c95a 2964 gfc_current_intrinsic, &substring->where,
c4aa95f8 2965 gfc_current_intrinsic_arg[0]->name);
524af0d6 2966 return false;
6de9cd9a
DN		 2967 }
2968
524af0d6 2969 return true;
6de9cd9a
DN		 2970}
2971
2972
524af0d6 2973bool
65f8144a 2974gfc_check_int (gfc_expr *x, gfc_expr *kind)
6de9cd9a 2975{
8dc63166
SK		 2976 /* BOZ is dealt within simplify_int*. */
2977 if (x->ts.type == BT_BOZ)
2978 return true;
2979
524af0d6
JB		 2980 if (!numeric_check (x, 0))
2981 return false;
c60d77d4 2982
524af0d6
JB		 2983 if (!kind_check (kind, 1, BT_INTEGER))
2984 return false;
c60d77d4 2985
524af0d6 2986 return true;
6de9cd9a
DN		 2987}
2988
2989
524af0d6 2990bool
65f8144a 2991gfc_check_intconv (gfc_expr *x)
bf3fb7e4 2992{
8dc63166
SK		 2993 if (strcmp (gfc_current_intrinsic, "short") == 0
2994 || strcmp (gfc_current_intrinsic, "long") == 0)
2995 {
2996 gfc_error ("%qs intrinsic subprogram at %L has been deprecated. "
2997 "Use INT intrinsic subprogram.", gfc_current_intrinsic,
2998 &x->where);
2999 return false;
3000 }
3001
3002 /* BOZ is dealt within simplify_int*. */
3003 if (x->ts.type == BT_BOZ)
3004 return true;
3005
524af0d6
JB		 3006 if (!numeric_check (x, 0))
3007 return false;
bf3fb7e4 3008
524af0d6 3009 return true;
bf3fb7e4
FXC		 3010}
3011
524af0d6 3012bool
65f8144a 3013gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
6de9cd9a 3014{
524af0d6
JB		 3015 if (!type_check (i, 0, BT_INTEGER)
3016 || !type_check (shift, 1, BT_INTEGER))
3017 return false;
6de9cd9a 3018
524af0d6
JB		 3019 if (!less_than_bitsize1 ("I", i, NULL, shift, true))
3020 return false;
0019028b 3021
524af0d6 3022 return true;
6de9cd9a
DN		 3023}
3024
3025
524af0d6 3026bool
65f8144a 3027gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
6de9cd9a 3028{
524af0d6
JB		 3029 if (!type_check (i, 0, BT_INTEGER)
3030 || !type_check (shift, 1, BT_INTEGER))
3031 return false;
6de9cd9a 3032
8b704316 3033 if (size != NULL)
0019028b
SK		 3034 {
3035 int i2, i3;
3036
524af0d6
JB		 3037 if (!type_check (size, 2, BT_INTEGER))
3038 return false;
0019028b 3039
524af0d6
JB		 3040 if (!less_than_bitsize1 ("I", i, "SIZE", size, true))
3041 return false;
0019028b 3042
6d8c9e5c 3043 if (size->expr_type == EXPR_CONSTANT)
0019028b 3044 {
6d8c9e5c
SK		 3045 gfc_extract_int (size, &i3);
3046 if (i3 <= 0)
3047 {
3048 gfc_error ("SIZE at %L must be positive", &size->where);
524af0d6 3049 return false;
6d8c9e5c 3050 }
0019028b 3051
6d8c9e5c
SK		 3052 if (shift->expr_type == EXPR_CONSTANT)
3053 {
3054 gfc_extract_int (shift, &i2);
3055 if (i2 < 0)
3056 i2 = -i2;
3057
3058 if (i2 > i3)
3059 {
fea70c99
MLI		 3060 gfc_error ("The absolute value of SHIFT at %L must be less "
3061 "than or equal to SIZE at %L", &shift->where,
3062 &size->where);
524af0d6 3063 return false;
6d8c9e5c
SK		 3064 }
3065 }
0019028b
SK		 3066 }
3067 }
524af0d6
JB		 3068 else if (!less_than_bitsize1 ("I", i, NULL, shift, true))
3069 return false;
6de9cd9a 3070
524af0d6 3071 return true;
6de9cd9a
DN		 3072}
3073
3074
524af0d6 3075bool
65f8144a 3076gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
f77b6ca3 3077{
524af0d6
JB		 3078 if (!type_check (pid, 0, BT_INTEGER))
3079 return false;
f77b6ca3 3080
fbe1f017
SK		 3081 if (!scalar_check (pid, 0))
3082 return false;
3083
524af0d6
JB		 3084 if (!type_check (sig, 1, BT_INTEGER))
3085 return false;
f77b6ca3 3086
fbe1f017
SK		 3087 if (!scalar_check (sig, 1))
3088 return false;
3089
524af0d6 3090 return true;
f77b6ca3
FXC		 3091}
3092
3093
524af0d6 3094bool
65f8144a 3095gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
f77b6ca3 3096{
524af0d6
JB		 3097 if (!type_check (pid, 0, BT_INTEGER))
3098 return false;
f77b6ca3 3099
524af0d6
JB		 3100 if (!scalar_check (pid, 0))
3101 return false;
c7944152 3102
524af0d6
JB		 3103 if (!type_check (sig, 1, BT_INTEGER))
3104 return false;
f77b6ca3 3105
524af0d6
JB		 3106 if (!scalar_check (sig, 1))
3107 return false;
c7944152 3108
17164de4 3109 if (status)
fbe1f017 3110 {
17164de4
SK		 3111 if (!type_check (status, 2, BT_INTEGER))
3112 return false;
3113
3114 if (!scalar_check (status, 2))
3115 return false;
fbe1f017
SK		 3116 }
3117
524af0d6 3118 return true;
f77b6ca3
FXC		 3119}
3120
3121
524af0d6 3122bool
65f8144a 3123gfc_check_kind (gfc_expr *x)
6de9cd9a 3124{
f6288c24 3125 if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
6de9cd9a 3126 {
0a6f1499
JW		 3127 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
3128 "intrinsic type", gfc_current_intrinsic_arg[0]->name,
4c93c95a 3129 gfc_current_intrinsic, &x->where);
524af0d6 3130 return false;
6de9cd9a 3131 }
0a6f1499
JW		 3132 if (x->ts.type == BT_PROCEDURE)
3133 {
3134 gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity",
3135 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
3136 &x->where);
3137 return false;
3138 }
6de9cd9a 3139
524af0d6 3140 return true;
6de9cd9a
DN		 3141}
3142
3143
524af0d6 3144bool
5cda5098 3145gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6de9cd9a 3146{
524af0d6
JB		 3147 if (!array_check (array, 0))
3148 return false;
6de9cd9a 3149
524af0d6
JB		 3150 if (!dim_check (dim, 1, false))
3151 return false;
6de9cd9a 3152
524af0d6
JB		 3153 if (!dim_rank_check (dim, array, 1))
3154 return false;
5cda5098 3155
524af0d6
JB		 3156 if (!kind_check (kind, 2, BT_INTEGER))
3157 return false;
a4d9b221 3158 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 3159 "with KIND argument at %L",
524af0d6
JB		 3160 gfc_current_intrinsic, &kind->where))
3161 return false;
5cda5098 3162
524af0d6 3163 return true;
5cda5098
FXC		 3164}
3165
3166
524af0d6 3167bool
64f002ed
TB		 3168gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
3169{
f19626cf 3170 if (flag_coarray == GFC_FCOARRAY_NONE)
64f002ed 3171 {
ddc05d11 3172 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
524af0d6 3173 return false;
64f002ed
TB		 3174 }
3175
524af0d6
JB		 3176 if (!coarray_check (coarray, 0))
3177 return false;
64f002ed
TB		 3178
3179 if (dim != NULL)
3180 {
524af0d6
JB		 3181 if (!dim_check (dim, 1, false))
3182 return false;
64f002ed 3183
524af0d6
JB		 3184 if (!dim_corank_check (dim, coarray))
3185 return false;
64f002ed
TB		 3186 }
3187
524af0d6
JB		 3188 if (!kind_check (kind, 2, BT_INTEGER))
3189 return false;
64f002ed 3190
524af0d6 3191 return true;
64f002ed
TB		 3192}
3193
3194
524af0d6 3195bool
5cda5098
FXC		 3196gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
3197{
524af0d6
JB		 3198 if (!type_check (s, 0, BT_CHARACTER))
3199 return false;
5cda5098 3200
524af0d6
JB		 3201 if (!kind_check (kind, 1, BT_INTEGER))
3202 return false;
a4d9b221 3203 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 3204 "with KIND argument at %L",
524af0d6
JB		 3205 gfc_current_intrinsic, &kind->where))
3206 return false;
5cda5098 3207
524af0d6 3208 return true;
6de9cd9a
DN		 3209}
3210
3211
524af0d6 3212bool
d393bbd7
FXC		 3213gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b)
3214{
524af0d6
JB		 3215 if (!type_check (a, 0, BT_CHARACTER))
3216 return false;
3217 if (!kind_value_check (a, 0, gfc_default_character_kind))
3218 return false;
d393bbd7 3219
524af0d6
JB		 3220 if (!type_check (b, 1, BT_CHARACTER))
3221 return false;
3222 if (!kind_value_check (b, 1, gfc_default_character_kind))
3223 return false;
d393bbd7 3224
524af0d6 3225 return true;
d393bbd7
FXC		 3226}
3227
3228
524af0d6 3229bool
65f8144a 3230gfc_check_link (gfc_expr *path1, gfc_expr *path2)
f77b6ca3 3231{
524af0d6
JB		 3232 if (!type_check (path1, 0, BT_CHARACTER))
3233 return false;
3234 if (!kind_value_check (path1, 0, gfc_default_character_kind))
3235 return false;
f77b6ca3 3236
524af0d6
JB		 3237 if (!type_check (path2, 1, BT_CHARACTER))
3238 return false;
3239 if (!kind_value_check (path2, 1, gfc_default_character_kind))
3240 return false;
f77b6ca3 3241
524af0d6 3242 return true;
f77b6ca3
FXC		 3243}
3244
3245
524af0d6 3246bool
65f8144a 3247gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
f77b6ca3 3248{
524af0d6
JB		 3249 if (!type_check (path1, 0, BT_CHARACTER))
3250 return false;
3251 if (!kind_value_check (path1, 0, gfc_default_character_kind))
3252 return false;
f77b6ca3 3253
524af0d6
JB		 3254 if (!type_check (path2, 1, BT_CHARACTER))
3255 return false;
3256 if (!kind_value_check (path2, 0, gfc_default_character_kind))
3257 return false;
f77b6ca3
FXC		 3258
3259 if (status == NULL)
524af0d6 3260 return true;
f77b6ca3 3261
524af0d6
JB		 3262 if (!type_check (status, 2, BT_INTEGER))
3263 return false;
f77b6ca3 3264
524af0d6
JB		 3265 if (!scalar_check (status, 2))
3266 return false;
f77b6ca3 3267
524af0d6 3268 return true;
f77b6ca3
FXC		 3269}
3270
65f8144a 3271
524af0d6 3272bool
83d890b9
AL		 3273gfc_check_loc (gfc_expr *expr)
3274{
11746b92 3275 return variable_check (expr, 0, true);
83d890b9
AL		 3276}
3277
f77b6ca3 3278
524af0d6 3279bool
65f8144a 3280gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
f77b6ca3 3281{
524af0d6
JB		 3282 if (!type_check (path1, 0, BT_CHARACTER))
3283 return false;
3284 if (!kind_value_check (path1, 0, gfc_default_character_kind))
3285 return false;
f77b6ca3 3286
524af0d6
JB		 3287 if (!type_check (path2, 1, BT_CHARACTER))
3288 return false;
3289 if (!kind_value_check (path2, 1, gfc_default_character_kind))
3290 return false;
f77b6ca3 3291
524af0d6 3292 return true;
f77b6ca3
FXC		 3293}
3294
3295
524af0d6 3296bool
65f8144a 3297gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
f77b6ca3 3298{
524af0d6
JB		 3299 if (!type_check (path1, 0, BT_CHARACTER))
3300 return false;
3301 if (!kind_value_check (path1, 0, gfc_default_character_kind))
3302 return false;
f77b6ca3 3303
524af0d6
JB		 3304 if (!type_check (path2, 1, BT_CHARACTER))
3305 return false;
3306 if (!kind_value_check (path2, 1, gfc_default_character_kind))
3307 return false;
f77b6ca3
FXC		 3308
3309 if (status == NULL)
524af0d6 3310 return true;
f77b6ca3 3311
524af0d6
JB		 3312 if (!type_check (status, 2, BT_INTEGER))
3313 return false;
f77b6ca3 3314
524af0d6
JB		 3315 if (!scalar_check (status, 2))
3316 return false;
f77b6ca3 3317
524af0d6 3318 return true;
f77b6ca3
FXC		 3319}
3320
3321
524af0d6 3322bool
65f8144a 3323gfc_check_logical (gfc_expr *a, gfc_expr *kind)
6de9cd9a 3324{
524af0d6
JB		 3325 if (!type_check (a, 0, BT_LOGICAL))
3326 return false;
3327 if (!kind_check (kind, 1, BT_LOGICAL))
3328 return false;
6de9cd9a 3329
524af0d6 3330 return true;
6de9cd9a
DN		 3331}
3332
3333
3334/* Min/max family. */
3335
524af0d6 3336static bool
3b833dcd 3337min_max_args (gfc_actual_arglist *args)
6de9cd9a 3338{
3b833dcd
TB		 3339 gfc_actual_arglist *arg;
3340 int i, j, nargs, *nlabels, nlabelless;
3341 bool a1 = false, a2 = false;
3342
3343 if (args == NULL || args->next == NULL)
6de9cd9a 3344 {
c4100eae 3345 gfc_error ("Intrinsic %qs at %L must have at least two arguments",
6de9cd9a 3346 gfc_current_intrinsic, gfc_current_intrinsic_where);
524af0d6 3347 return false;
6de9cd9a
DN		 3348 }
3349
3b833dcd
TB		 3350 if (!args->name)
3351 a1 = true;
3352
3353 if (!args->next->name)
3354 a2 = true;
3355
3356 nargs = 0;
3357 for (arg = args; arg; arg = arg->next)
3358 if (arg->name)
3359 nargs++;
3360
3361 if (nargs == 0)
3362 return true;
3363
3364 /* Note: Having a keywordless argument after an "arg=" is checked before. */
3365 nlabelless = 0;
3366 nlabels = XALLOCAVEC (int, nargs);
3367 for (arg = args, i = 0; arg; arg = arg->next, i++)
3368 if (arg->name)
3369 {
3370 int n;
3371 char *endp;
3372
3373 if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9')
3374 goto unknown;
3375 n = strtol (&arg->name[1], &endp, 10);
3376 if (endp[0] != '\0')
3377 goto unknown;
3378 if (n <= 0)
3379 goto unknown;
3380 if (n <= nlabelless)
3381 goto duplicate;
3382 nlabels[i] = n;
3383 if (n == 1)
3384 a1 = true;
3385 if (n == 2)
3386 a2 = true;
3387 }
3388 else
3389 nlabelless++;
3390
3391 if (!a1 || !a2)
3392 {
c4100eae 3393 gfc_error ("Missing %qs argument to the %s intrinsic at %L",
3b833dcd
TB		 3394 !a1 ? "a1" : "a2", gfc_current_intrinsic,
3395 gfc_current_intrinsic_where);
3396 return false;
3397 }
3398
3399 /* Check for duplicates. */
3400 for (i = 0; i < nargs; i++)
3401 for (j = i + 1; j < nargs; j++)
3402 if (nlabels[i] == nlabels[j])
3403 goto duplicate;
3404
524af0d6 3405 return true;
3b833dcd
TB		 3406
3407duplicate:
c4100eae 3408 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
3b833dcd
TB		 3409 &arg->expr->where, gfc_current_intrinsic);
3410 return false;
3411
3412unknown:
c4100eae 3413 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
3b833dcd
TB		 3414 &arg->expr->where, gfc_current_intrinsic);
3415 return false;
6de9cd9a
DN		 3416}
3417
3418
524af0d6 3419static bool
6495bc0b 3420check_rest (bt type, int kind, gfc_actual_arglist *arglist)
6de9cd9a 3421{
6495bc0b 3422 gfc_actual_arglist *arg, *tmp;
6495bc0b
DF		 3423 gfc_expr *x;
3424 int m, n;
6de9cd9a 3425
524af0d6
JB		 3426 if (!min_max_args (arglist))
3427 return false;
6de9cd9a 3428
6495bc0b 3429 for (arg = arglist, n=1; arg; arg = arg->next, n++)
6de9cd9a
DN		 3430 {
3431 x = arg->expr;
3432 if (x->ts.type != type || x->ts.kind != kind)
3433 {
65f8144a
SK		 3434 if (x->ts.type == type)
3435 {
524af0d6
JB		 3436 if (!gfc_notify_std (GFC_STD_GNU, "Different type "
3437 "kinds at %L", &x->where))
3438 return false;
65f8144a
SK		 3439 }
3440 else
3441 {
a4d9b221 3442 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
65f8144a
SK		 3443 "%s(%d)", n, gfc_current_intrinsic, &x->where,
3444 gfc_basic_typename (type), kind);
524af0d6 3445 return false;
65f8144a 3446 }
6de9cd9a 3447 }
0881653c 3448
6495bc0b 3449 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
a4d9b221 3450 if (!gfc_check_conformance (tmp->expr, x,
524af0d6 3451 "arguments 'a%d' and 'a%d' for "
a4d9b221 3452 "intrinsic '%s'", m, n,
524af0d6
JB		 3453 gfc_current_intrinsic))
3454 return false;
6de9cd9a
DN		 3455 }
3456
524af0d6 3457 return true;
6de9cd9a
DN		 3458}
3459
3460
524af0d6 3461bool
65f8144a 3462gfc_check_min_max (gfc_actual_arglist *arg)
6de9cd9a
DN		 3463{
3464 gfc_expr *x;
3465
524af0d6
JB		 3466 if (!min_max_args (arg))
3467 return false;
6de9cd9a
DN		 3468
3469 x = arg->expr;
3470
2263c775
FXC		 3471 if (x->ts.type == BT_CHARACTER)
3472 {
a4d9b221 3473 if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 3474 "with CHARACTER argument at %L",
524af0d6
JB		 3475 gfc_current_intrinsic, &x->where))
3476 return false;
2263c775
FXC		 3477 }
3478 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
6de9cd9a 3479 {
a4d9b221 3480 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
2263c775 3481 "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
524af0d6 3482 return false;
6de9cd9a
DN		 3483 }
3484
3485 return check_rest (x->ts.type, x->ts.kind, arg);
3486}
3487
3488
524af0d6 3489bool
65f8144a 3490gfc_check_min_max_integer (gfc_actual_arglist *arg)
6de9cd9a 3491{
9d64df18 3492 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
6de9cd9a
DN		 3493}
3494
3495
524af0d6 3496bool
65f8144a 3497gfc_check_min_max_real (gfc_actual_arglist *arg)
6de9cd9a 3498{
9d64df18 3499 return check_rest (BT_REAL, gfc_default_real_kind, arg);
6de9cd9a
DN		 3500}
3501
3502
524af0d6 3503bool
65f8144a 3504gfc_check_min_max_double (gfc_actual_arglist *arg)
6de9cd9a 3505{
9d64df18 3506 return check_rest (BT_REAL, gfc_default_double_kind, arg);
6de9cd9a
DN		 3507}
3508
65f8144a 3509
6de9cd9a
DN		 3510/* End of min/max family. */
3511
524af0d6 3512bool
65f8144a 3513gfc_check_malloc (gfc_expr *size)
0d519038 3514{
524af0d6
JB		 3515 if (!type_check (size, 0, BT_INTEGER))
3516 return false;
0d519038 3517
524af0d6
JB		 3518 if (!scalar_check (size, 0))
3519 return false;
0d519038 3520
524af0d6 3521 return true;
0d519038
FXC		 3522}
3523
6de9cd9a 3524
524af0d6 3525bool
65f8144a 3526gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
6de9cd9a 3527{
bf4f96e6 3528 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
6de9cd9a 3529 {
c4100eae 3530 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
c4aa95f8 3531 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
4c93c95a 3532 gfc_current_intrinsic, &matrix_a->where);
524af0d6 3533 return false;
6de9cd9a
DN		 3534 }
3535
bf4f96e6 3536 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
6de9cd9a 3537 {
c4100eae 3538 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
c4aa95f8 3539 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
4c93c95a 3540 gfc_current_intrinsic, &matrix_b->where);
524af0d6 3541 return false;
6de9cd9a
DN		 3542 }
3543
bf4f96e6
DF		 3544 if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
3545 || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
3546 {
c4100eae 3547 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
bf4f96e6
DF		 3548 gfc_current_intrinsic, &matrix_a->where,
3549 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
524af0d6 3550 return false;
bf4f96e6
DF		 3551 }
3552
6de9cd9a
DN		 3553 switch (matrix_a->rank)
3554 {
3555 case 1:
524af0d6
JB		 3556 if (!rank_check (matrix_b, 1, 2))
3557 return false;
a8999235 3558 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
65f8144a 3559 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
a8999235 3560 {
c4100eae
MLI		 3561 gfc_error ("Different shape on dimension 1 for arguments %qs "
3562 "and %qs at %L for intrinsic matmul",
c4aa95f8
JW		 3563 gfc_current_intrinsic_arg[0]->name,
3564 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
524af0d6 3565 return false;
a8999235 3566 }
6de9cd9a
DN		 3567 break;
3568
3569 case 2:
a8999235
TK		 3570 if (matrix_b->rank != 2)
3571 {
524af0d6
JB		 3572 if (!rank_check (matrix_b, 1, 1))
3573 return false;
a8999235
TK		 3574 }
3575 /* matrix_b has rank 1 or 2 here. Common check for the cases
3576 - matrix_a has shape (n,m) and matrix_b has shape (m, k)
3577 - matrix_a has shape (n,m) and matrix_b has shape (m). */
65f8144a 3578 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
a8999235 3579 {
c4100eae
MLI		 3580 gfc_error ("Different shape on dimension 2 for argument %qs and "
3581 "dimension 1 for argument %qs at %L for intrinsic "
c4aa95f8
JW		 3582 "matmul", gfc_current_intrinsic_arg[0]->name,
3583 gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
524af0d6 3584 return false;
a8999235 3585 }
6de9cd9a
DN		 3586 break;
3587
3588 default:
c4100eae 3589 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
c4aa95f8 3590 "1 or 2", gfc_current_intrinsic_arg[0]->name,
4c93c95a 3591 gfc_current_intrinsic, &matrix_a->where);
524af0d6 3592 return false;
6de9cd9a
DN		 3593 }
3594
524af0d6 3595 return true;
6de9cd9a
DN		 3596}
3597
3598
3599/* Whoever came up with this interface was probably on something.
3600 The possibilities for the occupation of the second and third
3601 parameters are:
3602
65f8144a
SK		 3603 Arg #2 Arg #3
3604 NULL NULL
3605 DIM NULL
3606 MASK NULL
3607 NULL MASK minloc(array, mask=m)
3608 DIM MASK
f3207b37
TS		 3609
3610 I.e. in the case of minloc(array,mask), mask will be in the second
64b1806b
TK		 3611 position of the argument list and we'll have to fix that up. Also,
3612 add the BACK argument if that isn't present. */
6de9cd9a 3613
524af0d6 3614bool
65f8144a 3615gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
6de9cd9a 3616{
64b1806b 3617 gfc_expr *a, *m, *d, *k, *b;
6de9cd9a 3618
f3207b37 3619 a = ap->expr;
ddc9995b 3620 if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0))
524af0d6 3621 return false;
6de9cd9a 3622
f3207b37
TS		 3623 d = ap->next->expr;
3624 m = ap->next->next->expr;
9a3d38f6 3625 k = ap->next->next->next->expr;
64b1806b
TK		 3626 b = ap->next->next->next->next->expr;
3627
3628 if (b)
3629 {
3630 if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4))
3631 return false;
64b1806b
TK		 3632 }
3633 else
3634 {
b573f931 3635 b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
64b1806b
TK		 3636 ap->next->next->next->next->expr = b;
3637 }
6de9cd9a 3638
f3207b37 3639 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
cb9e4f55 3640 && ap->next->name == NULL)
6de9cd9a 3641 {
f3207b37
TS		 3642 m = d;
3643 d = NULL;
f3207b37
TS		 3644 ap->next->expr = NULL;
3645 ap->next->next->expr = m;
6de9cd9a 3646 }
6de9cd9a 3647
524af0d6
JB		 3648 if (!dim_check (d, 1, false))
3649 return false;
ce99d594 3650
524af0d6
JB		 3651 if (!dim_rank_check (d, a, 0))
3652 return false;
6de9cd9a 3653
524af0d6
JB		 3654 if (m != NULL && !type_check (m, 2, BT_LOGICAL))
3655 return false;
6de9cd9a 3656
ca8a8795 3657 if (m != NULL
c7f587bd
PT		 3658 && !gfc_check_conformance (a, m,
3659 "arguments '%s' and '%s' for intrinsic %s",
3660 gfc_current_intrinsic_arg[0]->name,
3661 gfc_current_intrinsic_arg[2]->name,
524af0d6
JB		 3662 gfc_current_intrinsic))
3663 return false;
17d761bb 3664
9a3d38f6
TK		 3665 if (!kind_check (k, 1, BT_INTEGER))
3666 return false;
3667
524af0d6 3668 return true;
6de9cd9a
DN		 3669}
3670
01ce9e31
TK		 3671/* Check function for findloc. Mostly like gfc_check_minloc_maxloc
3672 above, with the additional "value" argument. */
3673
3674bool
3675gfc_check_findloc (gfc_actual_arglist *ap)
3676{
3677 gfc_expr *a, *v, *m, *d, *k, *b;
3678
3679 a = ap->expr;
3680 if (!intrinsic_type_check (a, 0) || !array_check (a, 0))
3681 return false;
3682
3683 v = ap->next->expr;
3684 if (!scalar_check (v,1))
3685 return false;
3686
3687 /* Check if the type is compatible. */
3688
3689 if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL)
3690 || (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL))
3691 {
3692 gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
3693 "conformance to argument %qs at %L",
3694 gfc_current_intrinsic_arg[0]->name,
3695 gfc_current_intrinsic, &a->where,
3696 gfc_current_intrinsic_arg[1]->name, &v->where);
3697 }
3698
3699 d = ap->next->next->expr;
3700 m = ap->next->next->next->expr;
3701 k = ap->next->next->next->next->expr;
3702 b = ap->next->next->next->next->next->expr;
3703
3704 if (b)
3705 {
3706 if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4))
3707 return false;
3708 }
3709 else
3710 {
3711 b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
3712 ap->next->next->next->next->next->expr = b;
3713 }
3714
3715 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
3716 && ap->next->name == NULL)
3717 {
3718 m = d;
3719 d = NULL;
3720 ap->next->next->expr = NULL;
3721 ap->next->next->next->expr = m;
3722 }
3723
3724 if (!dim_check (d, 2, false))
3725 return false;
3726
3727 if (!dim_rank_check (d, a, 0))
3728 return false;
3729
3730 if (m != NULL && !type_check (m, 3, BT_LOGICAL))
3731 return false;
3732
3733 if (m != NULL
3734 && !gfc_check_conformance (a, m,
3735 "arguments '%s' and '%s' for intrinsic %s",
3736 gfc_current_intrinsic_arg[0]->name,
3737 gfc_current_intrinsic_arg[3]->name,
3738 gfc_current_intrinsic))
3739 return false;
3740
3741 if (!kind_check (k, 1, BT_INTEGER))
3742 return false;
3743
3744 return true;
3745}
3746
6de9cd9a 3747
7551270e
ES		 3748/* Similar to minloc/maxloc, the argument list might need to be
3749 reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3750 difference is that MINLOC/MAXLOC take an additional KIND argument.
3751 The possibilities are:
3752
65f8144a
SK		 3753 Arg #2 Arg #3
3754 NULL NULL
3755 DIM NULL
3756 MASK NULL
3757 NULL MASK minval(array, mask=m)
3758 DIM MASK
7551270e
ES		 3759
3760 I.e. in the case of minval(array,mask), mask will be in the second
3761 position of the argument list and we'll have to fix that up. */
3762
524af0d6 3763static bool
65f8144a 3764check_reduction (gfc_actual_arglist *ap)
6de9cd9a 3765{
17d761bb 3766 gfc_expr *a, *m, *d;
6de9cd9a 3767
17d761bb 3768 a = ap->expr;
7551270e
ES		 3769 d = ap->next->expr;
3770 m = ap->next->next->expr;
6de9cd9a 3771
7551270e 3772 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
cb9e4f55 3773 && ap->next->name == NULL)
7551270e
ES		 3774 {
3775 m = d;
3776 d = NULL;
7551270e
ES		 3777 ap->next->expr = NULL;
3778 ap->next->next->expr = m;
3779 }
3780
524af0d6
JB		 3781 if (!dim_check (d, 1, false))
3782 return false;
ce99d594 3783
524af0d6
JB		 3784 if (!dim_rank_check (d, a, 0))
3785 return false;
6de9cd9a 3786
524af0d6
JB		 3787 if (m != NULL && !type_check (m, 2, BT_LOGICAL))
3788 return false;
6de9cd9a 3789
ca8a8795 3790 if (m != NULL
c7f587bd
PT		 3791 && !gfc_check_conformance (a, m,
3792 "arguments '%s' and '%s' for intrinsic %s",
3793 gfc_current_intrinsic_arg[0]->name,
3794 gfc_current_intrinsic_arg[2]->name,
524af0d6
JB		 3795 gfc_current_intrinsic))
3796 return false;
17d761bb 3797
524af0d6 3798 return true;
6de9cd9a
DN		 3799}
3800
3801
524af0d6 3802bool
65f8144a 3803gfc_check_minval_maxval (gfc_actual_arglist *ap)
617097a3 3804{
0ac74254 3805 if (!int_or_real_or_char_check_f2003 (ap->expr, 0)
524af0d6
JB		 3806 || !array_check (ap->expr, 0))
3807 return false;
27dfc9c4 3808
617097a3
TS		 3809 return check_reduction (ap);
3810}
3811
3812
524af0d6 3813bool
65f8144a 3814gfc_check_product_sum (gfc_actual_arglist *ap)
617097a3 3815{
524af0d6
JB		 3816 if (!numeric_check (ap->expr, 0)
3817 || !array_check (ap->expr, 0))
3818 return false;
27dfc9c4 3819
617097a3
TS		 3820 return check_reduction (ap);
3821}
3822
3823
195a95c4
TB		 3824/* For IANY, IALL and IPARITY. */
3825
524af0d6 3826bool
88a95a11
FXC		 3827gfc_check_mask (gfc_expr *i, gfc_expr *kind)
3828{
3829 int k;
3830
524af0d6
JB		 3831 if (!type_check (i, 0, BT_INTEGER))
3832 return false;
88a95a11 3833
524af0d6
JB		 3834 if (!nonnegative_check ("I", i))
3835 return false;
88a95a11 3836
524af0d6
JB		 3837 if (!kind_check (kind, 1, BT_INTEGER))
3838 return false;
88a95a11
FXC		 3839
3840 if (kind)
3841 gfc_extract_int (kind, &k);
3842 else
3843 k = gfc_default_integer_kind;
3844
524af0d6
JB		 3845 if (!less_than_bitsizekind ("I", i, k))
3846 return false;
88a95a11 3847
524af0d6 3848 return true;
88a95a11
FXC		 3849}
3850
3851
524af0d6 3852bool
195a95c4
TB		 3853gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
3854{
3855 if (ap->expr->ts.type != BT_INTEGER)
3856 {
c4100eae 3857 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
195a95c4
TB		 3858 gfc_current_intrinsic_arg[0]->name,
3859 gfc_current_intrinsic, &ap->expr->where);
524af0d6 3860 return false;
195a95c4
TB		 3861 }
3862
524af0d6
JB		 3863 if (!array_check (ap->expr, 0))
3864 return false;
195a95c4
TB		 3865
3866 return check_reduction (ap);
3867}
3868
3869
524af0d6 3870bool
65f8144a 3871gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
6de9cd9a 3872{
524af0d6
JB		 3873 if (!same_type_check (tsource, 0, fsource, 1))
3874 return false;
6de9cd9a 3875
524af0d6
JB		 3876 if (!type_check (mask, 2, BT_LOGICAL))
3877 return false;
6de9cd9a 3878
90d31126 3879 if (tsource->ts.type == BT_CHARACTER)
fb5bc08b 3880 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
90d31126 3881
524af0d6 3882 return true;
6de9cd9a
DN		 3883}
3884
90d31126 3885
524af0d6 3886bool
88a95a11
FXC		 3887gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
3888{
8dc63166
SK		 3889 /* i and j cannot both be BOZ literal constants. */
3890 if (!boz_args_check (i, j))
524af0d6 3891 return false;
88a95a11 3892
8dc63166
SK		 3893 /* If i is BOZ and j is integer, convert i to type of j. */
3894 if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
3895 && !gfc_boz2int (i, j->ts.kind))
524af0d6 3896 return false;
88a95a11 3897
8dc63166
SK		 3898 /* If j is BOZ and i is integer, convert j to type of i. */
3899 if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
3900 && !gfc_boz2int (j, i->ts.kind))
89c1cf26
SK		 3901 return false;
3902
8dc63166
SK		 3903 if (!type_check (i, 0, BT_INTEGER))
3904 return false;
89c1cf26 3905
8dc63166 3906 if (!type_check (j, 1, BT_INTEGER))
524af0d6 3907 return false;
88a95a11 3908
524af0d6
JB		 3909 if (!same_type_check (i, 0, j, 1))
3910 return false;
88a95a11 3911
8dc63166
SK		 3912 if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind))
3913 return false;
3914
3915 if (!type_check (mask, 2, BT_INTEGER))
524af0d6 3916 return false;
88a95a11 3917
8dc63166
SK		 3918 if (!same_type_check (i, 0, mask, 2))
3919 return false;
89c1cf26 3920
524af0d6 3921 return true;
88a95a11
FXC		 3922}
3923
3924
524af0d6 3925bool
65f8144a 3926gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
5046aff5 3927{
524af0d6
JB		 3928 if (!variable_check (from, 0, false))
3929 return false;
3930 if (!allocatable_check (from, 0))
3931 return false;
284943b0
TB		 3932 if (gfc_is_coindexed (from))
3933 {
3934 gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
3935 "coindexed", &from->where);
524af0d6 3936 return false;
284943b0 3937 }
5046aff5 3938
524af0d6
JB		 3939 if (!variable_check (to, 1, false))
3940 return false;
3941 if (!allocatable_check (to, 1))
3942 return false;
284943b0
TB		 3943 if (gfc_is_coindexed (to))
3944 {
3945 gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
3946 "coindexed", &to->where);
524af0d6 3947 return false;
284943b0 3948 }
5046aff5 3949
fde50fe6 3950 if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
e0516b05 3951 {
fde50fe6
TB		 3952 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
3953 "polymorphic if FROM is polymorphic",
284943b0 3954 &to->where);
524af0d6 3955 return false;
e0516b05
TB		 3956 }
3957
524af0d6
JB		 3958 if (!same_type_check (to, 1, from, 0))
3959 return false;
fde50fe6 3960
5046aff5
PT		 3961 if (to->rank != from->rank)
3962 {
284943b0
TB		 3963 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3964 "must have the same rank %d/%d", &to->where, from->rank,
3965 to->rank);
524af0d6 3966 return false;
284943b0
TB		 3967 }
3968
3969 /* IR F08/0040; cf. 12-006A. */
3970 if (gfc_get_corank (to) != gfc_get_corank (from))
3971 {
3972 gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
3973 "must have the same corank %d/%d", &to->where,
3974 gfc_get_corank (from), gfc_get_corank (to));
524af0d6 3975 return false;
5046aff5
PT		 3976 }
3977
bfcb501d
PT		 3978 /* This is based losely on F2003 12.4.1.7. It is intended to prevent
3979 the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
3980 and cmp2 are allocatable. After the allocation is transferred,
3981 the 'to' chain is broken by the nullification of the 'from'. A bit
3982 of reflection reveals that this can only occur for derived types
3983 with recursive allocatable components. */
3984 if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
c7f587bd
PT		 3985 && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
3986 {
bfcb501d
PT		 3987 gfc_ref *to_ref, *from_ref;
3988 to_ref = to->ref;
3989 from_ref = from->ref;
3990 bool aliasing = true;
3991
3992 for (; from_ref && to_ref;
3993 from_ref = from_ref->next, to_ref = to_ref->next)
3994 {
3995 if (to_ref->type != from->ref->type)
3996 aliasing = false;
3997 else if (to_ref->type == REF_ARRAY
3998 && to_ref->u.ar.type != AR_FULL
3999 && from_ref->u.ar.type != AR_FULL)
4000 /* Play safe; assume sections and elements are different. */
4001 aliasing = false;
4002 else if (to_ref->type == REF_COMPONENT
4003 && to_ref->u.c.component != from_ref->u.c.component)
4004 aliasing = false;
4005
4006 if (!aliasing)
4007 break;
4008 }
4009
4010 if (aliasing)
4011 {
4012 gfc_error ("The FROM and TO arguments at %L violate aliasing "
4013 "restrictions (F2003 12.4.1.7)", &to->where);
4014 return false;
4015 }
c7f587bd
PT		 4016 }
4017
f968d60b
TB		 4018 /* CLASS arguments: Make sure the vtab of from is present. */
4019 if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
7289d1c9 4020 gfc_find_vtab (&from->ts);
5046aff5 4021
524af0d6 4022 return true;
5046aff5 4023}
6de9cd9a 4024
65f8144a 4025
524af0d6 4026bool
65f8144a 4027gfc_check_nearest (gfc_expr *x, gfc_expr *s)
6de9cd9a 4028{
524af0d6
JB		 4029 if (!type_check (x, 0, BT_REAL))
4030 return false;
6de9cd9a 4031
524af0d6
JB		 4032 if (!type_check (s, 1, BT_REAL))
4033 return false;
6de9cd9a 4034
58a9e3c4
SK		 4035 if (s->expr_type == EXPR_CONSTANT)
4036 {
4037 if (mpfr_sgn (s->value.real) == 0)
4038 {
a4d9b221 4039 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
58a9e3c4 4040 &s->where);
524af0d6 4041 return false;
58a9e3c4
SK		 4042 }
4043 }
4044
524af0d6 4045 return true;
6de9cd9a
DN		 4046}
4047
65f8144a 4048
524af0d6 4049bool
65f8144a 4050gfc_check_new_line (gfc_expr *a)
bec93d79 4051{
524af0d6
JB		 4052 if (!type_check (a, 0, BT_CHARACTER))
4053 return false;
bec93d79 4054
524af0d6 4055 return true;
bec93d79 4056}
6de9cd9a 4057
65f8144a 4058
524af0d6 4059bool
0cd0559e
TB		 4060gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
4061{
524af0d6
JB		 4062 if (!type_check (array, 0, BT_REAL))
4063 return false;
0cd0559e 4064
524af0d6
JB		 4065 if (!array_check (array, 0))
4066 return false;
0cd0559e 4067
524af0d6
JB		 4068 if (!dim_rank_check (dim, array, false))
4069 return false;
0cd0559e 4070
524af0d6 4071 return true;
0cd0559e
TB		 4072}
4073
524af0d6 4074bool
65f8144a 4075gfc_check_null (gfc_expr *mold)
6de9cd9a
DN		 4076{
4077 symbol_attribute attr;
4078
4079 if (mold == NULL)
524af0d6 4080 return true;
6de9cd9a 4081
524af0d6
JB		 4082 if (!variable_check (mold, 0, true))
4083 return false;
6de9cd9a
DN		 4084
4085 attr = gfc_variable_attr (mold, NULL);
4086
ea8ad3e5 4087 if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
6de9cd9a 4088 {
c4100eae 4089 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
ea8ad3e5 4090 "ALLOCATABLE or procedure pointer",
c4aa95f8 4091 gfc_current_intrinsic_arg[0]->name,
5aacb11e 4092 gfc_current_intrinsic, &mold->where);
524af0d6 4093 return false;
5aacb11e
TB		 4094 }
4095
ea8ad3e5 4096 if (attr.allocatable
524af0d6
JB		 4097 && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with "
4098 "allocatable MOLD at %L", &mold->where))
4099 return false;
ea8ad3e5 4100
5aacb11e
TB		 4101 /* F2008, C1242. */
4102 if (gfc_is_coindexed (mold))
4103 {
c4100eae 4104 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
0c133211 4105 "coindexed", gfc_current_intrinsic_arg[0]->name,
4c93c95a 4106 gfc_current_intrinsic, &mold->where);
524af0d6 4107 return false;
6de9cd9a
DN		 4108 }
4109
524af0d6 4110 return true;
6de9cd9a
DN		 4111}
4112
4113
524af0d6 4114bool
65f8144a 4115gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
6de9cd9a 4116{
524af0d6
JB		 4117 if (!array_check (array, 0))
4118 return false;
6de9cd9a 4119
524af0d6
JB		 4120 if (!type_check (mask, 1, BT_LOGICAL))
4121 return false;
6de9cd9a 4122
c7f587bd
PT		 4123 if (!gfc_check_conformance (array, mask,
4124 "arguments '%s' and '%s' for intrinsic '%s'",
4125 gfc_current_intrinsic_arg[0]->name,
4126 gfc_current_intrinsic_arg[1]->name,
524af0d6
JB		 4127 gfc_current_intrinsic))
4128 return false;
6de9cd9a
DN		 4129
4130 if (vector != NULL)
4131 {
7ba8c18c
DF		 4132 mpz_t array_size, vector_size;
4133 bool have_array_size, have_vector_size;
4134
524af0d6
JB		 4135 if (!same_type_check (array, 0, vector, 2))
4136 return false;
6de9cd9a 4137
524af0d6
JB		 4138 if (!rank_check (vector, 2, 1))
4139 return false;
6de9cd9a 4140
7ba8c18c
DF		 4141 /* VECTOR requires at least as many elements as MASK
4142 has .TRUE. values. */
524af0d6
JB		 4143 have_array_size = gfc_array_size(array, &array_size);
4144 have_vector_size = gfc_array_size(vector, &vector_size);
7ba8c18c
DF		 4145
4146 if (have_vector_size
4147 && (mask->expr_type == EXPR_ARRAY
4148 || (mask->expr_type == EXPR_CONSTANT
4149 && have_array_size)))
4150 {
4151 int mask_true_values = 0;
4152
4153 if (mask->expr_type == EXPR_ARRAY)
4154 {
b7e75771
JD		 4155 gfc_constructor *mask_ctor;
4156 mask_ctor = gfc_constructor_first (mask->value.constructor);
7ba8c18c
DF		 4157 while (mask_ctor)
4158 {
4159 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
4160 {
4161 mask_true_values = 0;
4162 break;
4163 }
4164
4165 if (mask_ctor->expr->value.logical)
4166 mask_true_values++;
4167
b7e75771 4168 mask_ctor = gfc_constructor_next (mask_ctor);
7ba8c18c
DF		 4169 }
4170 }
4171 else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
4172 mask_true_values = mpz_get_si (array_size);
4173
4174 if (mpz_get_si (vector_size) < mask_true_values)
4175 {
c4100eae 4176 gfc_error ("%qs argument of %qs intrinsic at %L must "
7ba8c18c 4177 "provide at least as many elements as there "
c4100eae 4178 "are .TRUE. values in %qs (%ld/%d)",
c4aa95f8
JW		 4179 gfc_current_intrinsic_arg[2]->name,
4180 gfc_current_intrinsic, &vector->where,
4181 gfc_current_intrinsic_arg[1]->name,
7ba8c18c 4182 mpz_get_si (vector_size), mask_true_values);
524af0d6 4183 return false;
7ba8c18c
DF		 4184 }
4185 }
4186
4187 if (have_array_size)
4188 mpz_clear (array_size);
4189 if (have_vector_size)
4190 mpz_clear (vector_size);
6de9cd9a
DN		 4191 }
4192
524af0d6 4193 return true;
6de9cd9a
DN		 4194}
4195
4196
524af0d6 4197bool
0cd0559e
TB		 4198gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
4199{
524af0d6
JB		 4200 if (!type_check (mask, 0, BT_LOGICAL))
4201 return false;
0cd0559e 4202
524af0d6
JB		 4203 if (!array_check (mask, 0))
4204 return false;
0cd0559e 4205
524af0d6
JB		 4206 if (!dim_rank_check (dim, mask, false))
4207 return false;
0cd0559e 4208
524af0d6 4209 return true;
0cd0559e
TB		 4210}
4211
4212
524af0d6 4213bool
65f8144a 4214gfc_check_precision (gfc_expr *x)
6de9cd9a 4215{
524af0d6
JB		 4216 if (!real_or_complex_check (x, 0))
4217 return false;
6de9cd9a 4218
524af0d6 4219 return true;
6de9cd9a
DN		 4220}
4221
4222
524af0d6 4223bool
65f8144a 4224gfc_check_present (gfc_expr *a)
6de9cd9a
DN		 4225{
4226 gfc_symbol *sym;
4227
524af0d6
JB		 4228 if (!variable_check (a, 0, true))
4229 return false;
6de9cd9a
DN		 4230
4231 sym = a->symtree->n.sym;
4232 if (!sym->attr.dummy)
4233 {
c4100eae 4234 gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
c4aa95f8 4235 "dummy variable", gfc_current_intrinsic_arg[0]->name,
4c93c95a 4236 gfc_current_intrinsic, &a->where);
524af0d6 4237 return false;
6de9cd9a
DN		 4238 }
4239
4240 if (!sym->attr.optional)
4241 {
c4100eae 4242 gfc_error ("%qs argument of %qs intrinsic at %L must be of "
c4aa95f8
JW		 4243 "an OPTIONAL dummy variable",
4244 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4245 &a->where);
524af0d6 4246 return false;
6de9cd9a
DN		 4247 }
4248
65f8144a
SK		 4249 /* 13.14.82 PRESENT(A)
4250 ......
4251 Argument. A shall be the name of an optional dummy argument that is
4252 accessible in the subprogram in which the PRESENT function reference
4253 appears... */
72af9f0b
PT		 4254
4255 if (a->ref != NULL
65f8144a 4256 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
0c53708e
TB		 4257 && (a->ref->u.ar.type == AR_FULL
4258 || (a->ref->u.ar.type == AR_ELEMENT
4259 && a->ref->u.ar.as->rank == 0))))
72af9f0b 4260 {
c4100eae
MLI		 4261 gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
4262 "subobject of %qs", gfc_current_intrinsic_arg[0]->name,
72af9f0b 4263 gfc_current_intrinsic, &a->where, sym->name);
524af0d6 4264 return false;
72af9f0b
PT		 4265 }
4266
524af0d6 4267 return true;
6de9cd9a
DN		 4268}
4269
4270
524af0d6 4271bool
65f8144a 4272gfc_check_radix (gfc_expr *x)
6de9cd9a 4273{
524af0d6
JB		 4274 if (!int_or_real_check (x, 0))
4275 return false;
6de9cd9a 4276
524af0d6 4277 return true;
6de9cd9a
DN		 4278}
4279
4280
524af0d6 4281bool
65f8144a 4282gfc_check_range (gfc_expr *x)
6de9cd9a 4283{
524af0d6
JB		 4284 if (!numeric_check (x, 0))
4285 return false;
6de9cd9a 4286
524af0d6 4287 return true;
6de9cd9a
DN		 4288}
4289
4290
524af0d6 4291bool
6ed022af 4292gfc_check_rank (gfc_expr *a)
2514987f
TB		 4293{
4294 /* Any data object is allowed; a "data object" is a "constant (4.1.3),
4295 variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
4296
4297 bool is_variable = true;
4298
1cc0e193 4299 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
8b704316 4300 if (a->expr_type == EXPR_FUNCTION)
2514987f
TB		 4301 is_variable = a->value.function.esym
4302 ? a->value.function.esym->result->attr.pointer
4303 : a->symtree->n.sym->result->attr.pointer;
4304
9724eac3
SK		 4305 if (a->expr_type == EXPR_OP
4306 || a->expr_type == EXPR_NULL
4307 || a->expr_type == EXPR_COMPCALL
4308 || a->expr_type == EXPR_PPC
4309 || a->ts.type == BT_PROCEDURE
2514987f
TB		 4310 || !is_variable)
4311 {
4312 gfc_error ("The argument of the RANK intrinsic at %L must be a data "
4313 "object", &a->where);
524af0d6 4314 return false;
2514987f
TB		 4315 }
4316
524af0d6 4317 return true;
2514987f
TB		 4318}
4319
4320
524af0d6 4321bool
65f8144a 4322gfc_check_real (gfc_expr *a, gfc_expr *kind)
6de9cd9a 4323{
8dc63166 4324 if (!kind_check (kind, 1, BT_REAL))
524af0d6 4325 return false;
6de9cd9a 4326
8dc63166
SK		 4327 /* BOZ is dealt with in gfc_simplify_real. */
4328 if (a->ts.type == BT_BOZ)
4329 return true;
4330
4331 if (!numeric_check (a, 0))
524af0d6 4332 return false;
6de9cd9a 4333
524af0d6 4334 return true;
6de9cd9a
DN		 4335}
4336
4337
524af0d6 4338bool
65f8144a 4339gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
f77b6ca3 4340{
524af0d6
JB		 4341 if (!type_check (path1, 0, BT_CHARACTER))
4342 return false;
4343 if (!kind_value_check (path1, 0, gfc_default_character_kind))
4344 return false;
f77b6ca3 4345
524af0d6
JB		 4346 if (!type_check (path2, 1, BT_CHARACTER))
4347 return false;
4348 if (!kind_value_check (path2, 1, gfc_default_character_kind))
4349 return false;
f77b6ca3 4350
524af0d6 4351 return true;
f77b6ca3
FXC		 4352}
4353
4354
524af0d6 4355bool
65f8144a 4356gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
f77b6ca3 4357{
524af0d6
JB		 4358 if (!type_check (path1, 0, BT_CHARACTER))
4359 return false;
4360 if (!kind_value_check (path1, 0, gfc_default_character_kind))
4361 return false;
f77b6ca3 4362
524af0d6
JB		 4363 if (!type_check (path2, 1, BT_CHARACTER))
4364 return false;
4365 if (!kind_value_check (path2, 1, gfc_default_character_kind))
4366 return false;
f77b6ca3
FXC		 4367
4368 if (status == NULL)
524af0d6 4369 return true;
f77b6ca3 4370
524af0d6
JB		 4371 if (!type_check (status, 2, BT_INTEGER))
4372 return false;
f77b6ca3 4373
524af0d6
JB		 4374 if (!scalar_check (status, 2))
4375 return false;
f77b6ca3 4376
524af0d6 4377 return true;
f77b6ca3
FXC		 4378}
4379
4380
524af0d6 4381bool
65f8144a 4382gfc_check_repeat (gfc_expr *x, gfc_expr *y)
6de9cd9a 4383{
524af0d6
JB		 4384 if (!type_check (x, 0, BT_CHARACTER))
4385 return false;
6de9cd9a 4386
524af0d6
JB		 4387 if (!scalar_check (x, 0))
4388 return false;
6de9cd9a 4389
524af0d6
JB		 4390 if (!type_check (y, 0, BT_INTEGER))
4391 return false;
6de9cd9a 4392
524af0d6
JB		 4393 if (!scalar_check (y, 1))
4394 return false;
6de9cd9a 4395
524af0d6 4396 return true;
6de9cd9a
DN		 4397}
4398
4399
524af0d6 4400bool
65f8144a
SK		 4401gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
4402 gfc_expr *pad, gfc_expr *order)
6de9cd9a
DN		 4403{
4404 mpz_t size;
d8d8121a 4405 mpz_t nelems;
535ff342 4406 int shape_size;
6de9cd9a 4407
524af0d6
JB		 4408 if (!array_check (source, 0))
4409 return false;
6de9cd9a 4410
524af0d6
JB		 4411 if (!rank_check (shape, 1, 1))
4412 return false;
6de9cd9a 4413
524af0d6
JB		 4414 if (!type_check (shape, 1, BT_INTEGER))
4415 return false;
6de9cd9a 4416
524af0d6 4417 if (!gfc_array_size (shape, &size))
6de9cd9a 4418 {
a4d9b221 4419 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
6de9cd9a 4420 "array of constant size", &shape->where);
524af0d6 4421 return false;
6de9cd9a
DN		 4422 }
4423
535ff342 4424 shape_size = mpz_get_ui (size);
6de9cd9a
DN		 4425 mpz_clear (size);
4426
535ff342
DF		 4427 if (shape_size <= 0)
4428 {
c4100eae 4429 gfc_error ("%qs argument of %qs intrinsic at %L is empty",
c4aa95f8 4430 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
535ff342 4431 &shape->where);
524af0d6 4432 return false;
535ff342
DF		 4433 }
4434 else if (shape_size > GFC_MAX_DIMENSIONS)
6de9cd9a 4435 {
a4d9b221 4436 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
31043f6c 4437 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
524af0d6 4438 return false;
6de9cd9a 4439 }
df1c8791 4440 else if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
535ff342
DF		 4441 {
4442 gfc_expr *e;
4443 int i, extent;
4444 for (i = 0; i < shape_size; ++i)
4445 {
b7e75771 4446 e = gfc_constructor_lookup_expr (shape->value.constructor, i);
535ff342 4447 if (e->expr_type != EXPR_CONSTANT)
b7e75771 4448 continue;
535ff342
DF		 4449
4450 gfc_extract_int (e, &extent);
4451 if (extent < 0)
4452 {
c4100eae 4453 gfc_error ("%qs argument of %qs intrinsic at %L has "
c4aa95f8
JW		 4454 "negative element (%d)",
4455 gfc_current_intrinsic_arg[1]->name,
535ff342 4456 gfc_current_intrinsic, &e->where, extent);
524af0d6 4457 return false;
535ff342 4458 }
535ff342
DF		 4459 }
4460 }
57e59620
SK		 4461 else if (shape->expr_type == EXPR_VARIABLE && shape->ref
4462 && shape->ref->u.ar.type == AR_FULL && shape->ref->u.ar.dimen == 1
4463 && shape->ref->u.ar.as
4464 && shape->ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
4465 && shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER
4466 && shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT
4467 && shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER
4468 && shape->symtree->n.sym->attr.flavor == FL_PARAMETER)
4469 {
4470 int i, extent;
4471 gfc_expr *e, *v;
4472
4473 v = shape->symtree->n.sym->value;
4474
4475 for (i = 0; i < shape_size; i++)
4476 {
4477 e = gfc_constructor_lookup_expr (v->value.constructor, i);
4478 if (e == NULL)
4479 break;
4480
4481 gfc_extract_int (e, &extent);
4482
4483 if (extent < 0)
4484 {
4485 gfc_error ("Element %d of actual argument of RESHAPE at %L "
4486 "cannot be negative", i + 1, &shape->where);
4487 return false;
4488 }
4489 }
4490 }
6de9cd9a
DN		 4491
4492 if (pad != NULL)
4493 {
524af0d6
JB		 4494 if (!same_type_check (source, 0, pad, 2))
4495 return false;
535ff342 4496
524af0d6
JB		 4497 if (!array_check (pad, 2))
4498 return false;
6de9cd9a
DN		 4499 }
4500
535ff342
DF		 4501 if (order != NULL)
4502 {
524af0d6
JB		 4503 if (!array_check (order, 3))
4504 return false;
535ff342 4505
524af0d6
JB		 4506 if (!type_check (order, 3, BT_INTEGER))
4507 return false;
535ff342 4508
9fcb2819 4509 if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
535ff342
DF		 4510 {
4511 int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
4512 gfc_expr *e;
4513
4514 for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
4515 perm[i] = 0;
4516
4517 gfc_array_size (order, &size);
4518 order_size = mpz_get_ui (size);
4519 mpz_clear (size);
4520
4521 if (order_size != shape_size)
4522 {
c4100eae 4523 gfc_error ("%qs argument of %qs intrinsic at %L "
8b704316 4524 "has wrong number of elements (%d/%d)",
c4aa95f8 4525 gfc_current_intrinsic_arg[3]->name,
535ff342
DF		 4526 gfc_current_intrinsic, &order->where,
4527 order_size, shape_size);
524af0d6 4528 return false;
535ff342
DF		 4529 }
4530
4531 for (i = 1; i <= order_size; ++i)
4532 {
b7e75771 4533 e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
535ff342 4534 if (e->expr_type != EXPR_CONSTANT)
b7e75771 4535 continue;
535ff342
DF		 4536
4537 gfc_extract_int (e, &dim);
4538
4539 if (dim < 1 || dim > order_size)
4540 {
c4100eae 4541 gfc_error ("%qs argument of %qs intrinsic at %L "
8b704316 4542 "has out-of-range dimension (%d)",
c4aa95f8 4543 gfc_current_intrinsic_arg[3]->name,
535ff342 4544 gfc_current_intrinsic, &e->where, dim);
524af0d6 4545 return false;
535ff342
DF		 4546 }
4547
4548 if (perm[dim-1] != 0)
4549 {
c4100eae 4550 gfc_error ("%qs argument of %qs intrinsic at %L has "
535ff342 4551 "invalid permutation of dimensions (dimension "
8d4227c8 4552 "%qd duplicated)",
c4aa95f8 4553 gfc_current_intrinsic_arg[3]->name,
535ff342 4554 gfc_current_intrinsic, &e->where, dim);
524af0d6 4555 return false;
535ff342
DF		 4556 }
4557
4558 perm[dim-1] = 1;
535ff342
DF		 4559 }
4560 }
4561 }
6de9cd9a 4562
65f8144a
SK		 4563 if (pad == NULL && shape->expr_type == EXPR_ARRAY
4564 && gfc_is_constant_expr (shape)
4565 && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
4566 && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
d8d8121a
PT		 4567 {
4568 /* Check the match in size between source and destination. */
524af0d6 4569 if (gfc_array_size (source, &nelems))
d8d8121a
PT		 4570 {
4571 gfc_constructor *c;
4572 bool test;
4573
8b704316 4574
d8d8121a 4575 mpz_init_set_ui (size, 1);
b7e75771
JD		 4576 for (c = gfc_constructor_first (shape->value.constructor);
4577 c; c = gfc_constructor_next (c))
d8d8121a
PT		 4578 mpz_mul (size, size, c->expr->value.integer);
4579
4580 test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
4581 mpz_clear (nelems);
4582 mpz_clear (size);
4583
4584 if (test)
4585 {
65f8144a
SK		 4586 gfc_error ("Without padding, there are not enough elements "
4587 "in the intrinsic RESHAPE source at %L to match "
4588 "the shape", &source->where);
524af0d6 4589 return false;
d8d8121a
PT		 4590 }
4591 }
4592 }
4593
524af0d6 4594 return true;
6de9cd9a
DN		 4595}
4596
4597
524af0d6 4598bool
cf2b3c22
TB		 4599gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
4600{
cf2b3c22
TB		 4601 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
4602 {
c4100eae 4603 gfc_error ("%qs argument of %qs intrinsic at %L "
8b704316
PT		 4604 "cannot be of type %s",
4605 gfc_current_intrinsic_arg[0]->name,
4606 gfc_current_intrinsic,
4607 &a->where, gfc_typename (&a->ts));
524af0d6 4608 return false;
cf2b3c22
TB		 4609 }
4610
8b704316 4611 if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
cf2b3c22 4612 {
c4100eae 4613 gfc_error ("%qs argument of %qs intrinsic at %L "
c4aa95f8
JW		 4614 "must be of an extensible type",
4615 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4616 &a->where);
524af0d6 4617 return false;
cf2b3c22
TB		 4618 }
4619
4620 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
4621 {
c4100eae 4622 gfc_error ("%qs argument of %qs intrinsic at %L "
8b704316
PT		 4623 "cannot be of type %s",
4624 gfc_current_intrinsic_arg[0]->name,
4625 gfc_current_intrinsic,
4626 &b->where, gfc_typename (&b->ts));
524af0d6 4627 return false;
cf2b3c22
TB		 4628 }
4629
8b704316 4630 if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
cf2b3c22 4631 {
c4100eae 4632 gfc_error ("%qs argument of %qs intrinsic at %L "
c4aa95f8
JW		 4633 "must be of an extensible type",
4634 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
4635 &b->where);
524af0d6 4636 return false;
cf2b3c22
TB		 4637 }
4638
524af0d6 4639 return true;
cf2b3c22
TB		 4640}
4641
4642
524af0d6 4643bool
65f8144a 4644gfc_check_scale (gfc_expr *x, gfc_expr *i)
6de9cd9a 4645{
524af0d6
JB		 4646 if (!type_check (x, 0, BT_REAL))
4647 return false;
6de9cd9a 4648
524af0d6
JB		 4649 if (!type_check (i, 1, BT_INTEGER))
4650 return false;
6de9cd9a 4651
524af0d6 4652 return true;
6de9cd9a
DN		 4653}
4654
4655
524af0d6 4656bool
5cda5098 4657gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
6de9cd9a 4658{
524af0d6
JB		 4659 if (!type_check (x, 0, BT_CHARACTER))
4660 return false;
6de9cd9a 4661
524af0d6
JB		 4662 if (!type_check (y, 1, BT_CHARACTER))
4663 return false;
6de9cd9a 4664
524af0d6
JB		 4665 if (z != NULL && !type_check (z, 2, BT_LOGICAL))
4666 return false;
6de9cd9a 4667
524af0d6
JB		 4668 if (!kind_check (kind, 3, BT_INTEGER))
4669 return false;
a4d9b221 4670 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 4671 "with KIND argument at %L",
524af0d6
JB		 4672 gfc_current_intrinsic, &kind->where))
4673 return false;
5cda5098 4674
524af0d6
JB		 4675 if (!same_type_check (x, 0, y, 1))
4676 return false;
6de9cd9a 4677
524af0d6 4678 return true;
6de9cd9a
DN		 4679}
4680
4681
524af0d6 4682bool
65f8144a 4683gfc_check_secnds (gfc_expr *r)
53096259 4684{
524af0d6
JB		 4685 if (!type_check (r, 0, BT_REAL))
4686 return false;
53096259 4687
524af0d6
JB		 4688 if (!kind_value_check (r, 0, 4))
4689 return false;
53096259 4690
524af0d6
JB		 4691 if (!scalar_check (r, 0))
4692 return false;
53096259 4693
524af0d6 4694 return true;
53096259
PT		 4695}
4696
4697
524af0d6 4698bool
a39fafac
FXC		 4699gfc_check_selected_char_kind (gfc_expr *name)
4700{
524af0d6
JB		 4701 if (!type_check (name, 0, BT_CHARACTER))
4702 return false;
a39fafac 4703
524af0d6
JB		 4704 if (!kind_value_check (name, 0, gfc_default_character_kind))
4705 return false;
a39fafac 4706
524af0d6
JB		 4707 if (!scalar_check (name, 0))
4708 return false;
a39fafac 4709
524af0d6 4710 return true;
a39fafac
FXC		 4711}
4712
4713
524af0d6 4714bool
65f8144a 4715gfc_check_selected_int_kind (gfc_expr *r)
145cf79b 4716{
524af0d6
JB		 4717 if (!type_check (r, 0, BT_INTEGER))
4718 return false;
145cf79b 4719
524af0d6
JB		 4720 if (!scalar_check (r, 0))
4721 return false;
145cf79b 4722
524af0d6 4723 return true;
145cf79b
SK		 4724}
4725
4726
524af0d6 4727bool
01349049 4728gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
6de9cd9a 4729{
01349049 4730 if (p == NULL && r == NULL
524af0d6 4731 && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
c7f587bd 4732 " neither %<P%> nor %<R%> argument at %L",
524af0d6
JB		 4733 gfc_current_intrinsic_where))
4734 return false;
6de9cd9a 4735
70987f62
DF		 4736 if (p)
4737 {
524af0d6
JB		 4738 if (!type_check (p, 0, BT_INTEGER))
4739 return false;
6de9cd9a 4740
524af0d6
JB		 4741 if (!scalar_check (p, 0))
4742 return false;
70987f62
DF		 4743 }
4744
4745 if (r)
4746 {
524af0d6
JB		 4747 if (!type_check (r, 1, BT_INTEGER))
4748 return false;
70987f62 4749
524af0d6
JB		 4750 if (!scalar_check (r, 1))
4751 return false;
70987f62 4752 }
6de9cd9a 4753
01349049
TB		 4754 if (radix)
4755 {
524af0d6
JB		 4756 if (!type_check (radix, 1, BT_INTEGER))
4757 return false;
01349049 4758
524af0d6
JB		 4759 if (!scalar_check (radix, 1))
4760 return false;
01349049 4761
a4d9b221 4762 if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
c7f587bd 4763 "RADIX argument at %L", gfc_current_intrinsic,
524af0d6
JB		 4764 &radix->where))
4765 return false;
01349049
TB		 4766 }
4767
524af0d6 4768 return true;
6de9cd9a
DN		 4769}
4770
4771
524af0d6 4772bool
65f8144a 4773gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
6de9cd9a 4774{
524af0d6
JB		 4775 if (!type_check (x, 0, BT_REAL))
4776 return false;
6de9cd9a 4777
524af0d6
JB		 4778 if (!type_check (i, 1, BT_INTEGER))
4779 return false;
6de9cd9a 4780
524af0d6 4781 return true;
6de9cd9a
DN		 4782}
4783
4784
524af0d6 4785bool
7320cf09 4786gfc_check_shape (gfc_expr *source, gfc_expr *kind)
6de9cd9a
DN		 4787{
4788 gfc_array_ref *ar;
4789
4790 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
524af0d6 4791 return true;
6de9cd9a
DN		 4792
4793 ar = gfc_find_array_ref (source);
4794
86288ff0 4795 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
6de9cd9a 4796 {
a4d9b221 4797 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
6de9cd9a 4798 "an assumed size array", &source->where);
524af0d6 4799 return false;
6de9cd9a
DN		 4800 }
4801
524af0d6
JB		 4802 if (!kind_check (kind, 1, BT_INTEGER))
4803 return false;
a4d9b221 4804 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 4805 "with KIND argument at %L",
524af0d6
JB		 4806 gfc_current_intrinsic, &kind->where))
4807 return false;
7320cf09 4808
524af0d6 4809 return true;
6de9cd9a
DN		 4810}
4811
4812
524af0d6 4813bool
88a95a11
FXC		 4814gfc_check_shift (gfc_expr *i, gfc_expr *shift)
4815{
524af0d6
JB		 4816 if (!type_check (i, 0, BT_INTEGER))
4817 return false;
88a95a11 4818
524af0d6
JB		 4819 if (!type_check (shift, 0, BT_INTEGER))
4820 return false;
88a95a11 4821
524af0d6
JB		 4822 if (!nonnegative_check ("SHIFT", shift))
4823 return false;
88a95a11 4824
524af0d6
JB		 4825 if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
4826 return false;
88a95a11 4827
524af0d6 4828 return true;
88a95a11
FXC		 4829}
4830
4831
524af0d6 4832bool
65f8144a 4833gfc_check_sign (gfc_expr *a, gfc_expr *b)
6de9cd9a 4834{
524af0d6
JB		 4835 if (!int_or_real_check (a, 0))
4836 return false;
6de9cd9a 4837
524af0d6
JB		 4838 if (!same_type_check (a, 0, b, 1))
4839 return false;
27dfc9c4 4840
524af0d6 4841 return true;
27dfc9c4
TS		 4842}
4843
4844
524af0d6 4845bool
5cda5098 4846gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
27dfc9c4 4847{
524af0d6
JB		 4848 if (!array_check (array, 0))
4849 return false;
6de9cd9a 4850
524af0d6
JB		 4851 if (!dim_check (dim, 1, true))
4852 return false;
6de9cd9a 4853
524af0d6
JB		 4854 if (!dim_rank_check (dim, array, 0))
4855 return false;
6de9cd9a 4856
524af0d6
JB		 4857 if (!kind_check (kind, 2, BT_INTEGER))
4858 return false;
a4d9b221 4859 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 4860 "with KIND argument at %L",
524af0d6
JB		 4861 gfc_current_intrinsic, &kind->where))
4862 return false;
5cda5098
FXC		 4863
4864
524af0d6 4865 return true;
6de9cd9a
DN		 4866}
4867
4868
524af0d6 4869bool
2c23ebfe 4870gfc_check_sizeof (gfc_expr *arg)
fd2157ce 4871{
2c23ebfe
JW		 4872 if (arg->ts.type == BT_PROCEDURE)
4873 {
c4100eae 4874 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
2c23ebfe
JW		 4875 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4876 &arg->where);
524af0d6 4877 return false;
2c23ebfe 4878 }
1a8c1e35 4879
69c3654c
TB		 4880 /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
4881 if (arg->ts.type == BT_ASSUMED
4882 && (arg->symtree->n.sym->as == NULL
4883 || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
4884 && arg->symtree->n.sym->as->type != AS_DEFERRED
4885 && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
1a8c1e35 4886 {
c4100eae 4887 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
1a8c1e35
TB		 4888 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
4889 &arg->where);
524af0d6 4890 return false;
1a8c1e35
TB		 4891 }
4892
4893 if (arg->rank && arg->expr_type == EXPR_VARIABLE
4894 && arg->symtree->n.sym->as != NULL
4895 && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
4896 && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
4897 {
c4100eae 4898 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
1a8c1e35
TB		 4899 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
4900 gfc_current_intrinsic, &arg->where);
524af0d6 4901 return false;
1a8c1e35
TB		 4902 }
4903
524af0d6 4904 return true;
fd2157ce
TS		 4905}
4906
4907
cadddfdd
TB		 4908/* Check whether an expression is interoperable. When returning false,
4909 msg is set to a string telling why the expression is not interoperable,
4910 otherwise, it is set to NULL. The msg string can be used in diagnostics.
6082753e
TB		 4911 If c_loc is true, character with len > 1 are allowed (cf. Fortran
4912 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5e7ea214 4913 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
1cc0e193 4914 are permitted. */
cadddfdd
TB		 4915
4916static bool
5e7ea214 4917is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
cadddfdd
TB		 4918{
4919 *msg = NULL;
4920
4921 if (expr->ts.type == BT_CLASS)
4922 {
4923 *msg = "Expression is polymorphic";
4924 return false;
4925 }
4926
4927 if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
4928 && !expr->ts.u.derived->ts.is_iso_c)
4929 {
4930 *msg = "Expression is a noninteroperable derived type";
4931 return false;
4932 }
4933
4934 if (expr->ts.type == BT_PROCEDURE)
4935 {
4936 *msg = "Procedure unexpected as argument";
4937 return false;
4938 }
4939
4940 if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
4941 {
4942 int i;
4943 for (i = 0; gfc_logical_kinds[i].kind; i++)
4944 if (gfc_logical_kinds[i].kind == expr->ts.kind)
4945 return true;
4946 *msg = "Extension to use a non-C_Bool-kind LOGICAL";
4947 return false;
4948 }
4949
4950 if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
4951 && expr->ts.kind != 1)
4952 {
4953 *msg = "Extension to use a non-C_CHAR-kind CHARACTER";
4954 return false;
4955 }
4956
4957 if (expr->ts.type == BT_CHARACTER) {
4958 if (expr->ts.deferred)
4959 {
4960 /* TS 29113 allows deferred-length strings as dummy arguments,
1cc0e193 4961 but it is not an interoperable type. */
cadddfdd
TB		 4962 *msg = "Expression shall not be a deferred-length string";
4963 return false;
4964 }
4965
4966 if (expr->ts.u.cl && expr->ts.u.cl->length
d52d3767 4967 && !gfc_simplify_expr (expr->ts.u.cl->length, 0))
cadddfdd
TB		 4968 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
4969
6082753e 4970 if (!c_loc && expr->ts.u.cl
cadddfdd
TB		 4971 && (!expr->ts.u.cl->length
4972 || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
4973 || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
4974 {
4975 *msg = "Type shall have a character length of 1";
4976 return false;
4977 }
4978 }
4979
4980 /* Note: The following checks are about interoperatable variables, Fortran
4981 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
4982 is allowed, e.g. assumed-shape arrays with TS 29113. */
4983
4984 if (gfc_is_coarray (expr))
4985 {
4986 *msg = "Coarrays are not interoperable";
4987 return false;
4988 }
4989
6082753e 4990 if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
cadddfdd
TB		 4991 {
4992 gfc_array_ref *ar = gfc_find_array_ref (expr);
4993 if (ar->type != AR_FULL)
4994 {
4995 *msg = "Only whole-arrays are interoperable";
4996 return false;
4997 }
5e7ea214
TB		 4998 if (!c_f_ptr && ar->as->type != AS_EXPLICIT
4999 && ar->as->type != AS_ASSUMED_SIZE)
cadddfdd
TB		 5000 {
5001 *msg = "Only explicit-size and assumed-size arrays are interoperable";
5002 return false;
5003 }
5004 }
5005
5006 return true;
5007}
5008
5009
524af0d6 5010bool
048510c8
JW		 5011gfc_check_c_sizeof (gfc_expr *arg)
5012{
cadddfdd
TB		 5013 const char *msg;
5014
5e7ea214 5015 if (!is_c_interoperable (arg, &msg, false, false))
048510c8 5016 {
c4100eae 5017 gfc_error ("%qs argument of %qs intrinsic at %L must be an "
cadddfdd 5018 "interoperable data entity: %s",
c4aa95f8 5019 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
cadddfdd 5020 &arg->where, msg);
524af0d6 5021 return false;
cadddfdd
TB		 5022 }
5023
1a8c1e35
TB		 5024 if (arg->ts.type == BT_ASSUMED)
5025 {
c4100eae 5026 gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
1a8c1e35
TB		 5027 "TYPE(*)",
5028 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5029 &arg->where);
524af0d6 5030 return false;
1a8c1e35
TB		 5031 }
5032
cadddfdd
TB		 5033 if (arg->rank && arg->expr_type == EXPR_VARIABLE
5034 && arg->symtree->n.sym->as != NULL
5035 && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
5036 && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
5037 {
c4100eae 5038 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
cadddfdd
TB		 5039 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
5040 gfc_current_intrinsic, &arg->where);
524af0d6 5041 return false;
cadddfdd
TB		 5042 }
5043
524af0d6 5044 return true;
cadddfdd
TB		 5045}
5046
5047
524af0d6 5048bool
cadddfdd
TB		 5049gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
5050{
5051 if (c_ptr_1->ts.type != BT_DERIVED
5052 || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
5053 || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
5054 && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
5055 {
5056 gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
5057 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
524af0d6 5058 return false;
cadddfdd
TB		 5059 }
5060
524af0d6
JB		 5061 if (!scalar_check (c_ptr_1, 0))
5062 return false;
cadddfdd
TB		 5063
5064 if (c_ptr_2
5065 && (c_ptr_2->ts.type != BT_DERIVED
5066 || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
5067 || (c_ptr_1->ts.u.derived->intmod_sym_id
5068 != c_ptr_2->ts.u.derived->intmod_sym_id)))
5069 {
5070 gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
5071 "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
5072 gfc_typename (&c_ptr_1->ts),
5073 gfc_typename (&c_ptr_2->ts));
524af0d6 5074 return false;
cadddfdd
TB		 5075 }
5076
524af0d6
JB		 5077 if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
5078 return false;
cadddfdd 5079
524af0d6 5080 return true;
cadddfdd
TB		 5081}
5082
5083
524af0d6 5084bool
cadddfdd
TB		 5085gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
5086{
5087 symbol_attribute attr;
5088 const char *msg;
5089
5090 if (cptr->ts.type != BT_DERIVED
5091 || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
5092 || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
5093 {
5094 gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
5095 "type TYPE(C_PTR)", &cptr->where);
524af0d6 5096 return false;
cadddfdd
TB		 5097 }
5098
524af0d6
JB		 5099 if (!scalar_check (cptr, 0))
5100 return false;
cadddfdd
TB		 5101
5102 attr = gfc_expr_attr (fptr);
5103
5104 if (!attr.pointer)
5105 {
5106 gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
5107 &fptr->where);
524af0d6 5108 return false;
cadddfdd
TB		 5109 }
5110
5111 if (fptr->ts.type == BT_CLASS)
5112 {
5113 gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
5114 &fptr->where);
524af0d6 5115 return false;
cadddfdd
TB		 5116 }
5117
5118 if (gfc_is_coindexed (fptr))
5119 {
5120 gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
5121 "coindexed", &fptr->where);
524af0d6 5122 return false;
cadddfdd
TB		 5123 }
5124
5125 if (fptr->rank == 0 && shape)
5126 {
5127 gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
5128 "FPTR", &fptr->where);
524af0d6 5129 return false;
cadddfdd
TB		 5130 }
5131 else if (fptr->rank && !shape)
5132 {
5133 gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
5134 "FPTR at %L", &fptr->where);
524af0d6 5135 return false;
cadddfdd
TB		 5136 }
5137
524af0d6
JB		 5138 if (shape && !rank_check (shape, 2, 1))
5139 return false;
cadddfdd 5140
524af0d6
JB		 5141 if (shape && !type_check (shape, 2, BT_INTEGER))
5142 return false;
cadddfdd
TB		 5143
5144 if (shape)
5145 {
5146 mpz_t size;
f1ed9e15 5147 if (gfc_array_size (shape, &size))
cadddfdd 5148 {
f1ed9e15
JW		 5149 if (mpz_cmp_ui (size, fptr->rank) != 0)
5150 {
5151 mpz_clear (size);
5152 gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
5153 "size as the RANK of FPTR", &shape->where);
5154 return false;
5155 }
cadddfdd 5156 mpz_clear (size);
cadddfdd 5157 }
cadddfdd
TB		 5158 }
5159
5160 if (fptr->ts.type == BT_CLASS)
5161 {
5162 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
524af0d6 5163 return false;
cadddfdd
TB		 5164 }
5165
a2b471e4 5166 if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true))
286f737c 5167 return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR "
cadddfdd
TB		 5168 "at %L to C_F_POINTER: %s", &fptr->where, msg);
5169
524af0d6 5170 return true;
cadddfdd
TB		 5171}
5172
5173
524af0d6 5174bool
cadddfdd
TB		 5175gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
5176{
5177 symbol_attribute attr;
5178
5179 if (cptr->ts.type != BT_DERIVED
5180 || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
5181 || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
5182 {
5183 gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
5184 "type TYPE(C_FUNPTR)", &cptr->where);
524af0d6 5185 return false;
cadddfdd
TB		 5186 }
5187
524af0d6
JB		 5188 if (!scalar_check (cptr, 0))
5189 return false;
cadddfdd
TB		 5190
5191 attr = gfc_expr_attr (fptr);
5192
5193 if (!attr.proc_pointer)
5194 {
5195 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
5196 "pointer", &fptr->where);
524af0d6 5197 return false;
cadddfdd
TB		 5198 }
5199
5200 if (gfc_is_coindexed (fptr))
5201 {
5202 gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
5203 "coindexed", &fptr->where);
524af0d6 5204 return false;
cadddfdd
TB		 5205 }
5206
5207 if (!attr.is_bind_c)
286f737c 5208 return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
cadddfdd
TB		 5209 "pointer at %L to C_F_PROCPOINTER", &fptr->where);
5210
524af0d6 5211 return true;
cadddfdd
TB		 5212}
5213
5214
524af0d6 5215bool
cadddfdd
TB		 5216gfc_check_c_funloc (gfc_expr *x)
5217{
5218 symbol_attribute attr;
5219
5220 if (gfc_is_coindexed (x))
5221 {
5222 gfc_error ("Argument X at %L to C_FUNLOC shall not be "
5223 "coindexed", &x->where);
524af0d6 5224 return false;
048510c8 5225 }
cadddfdd
TB		 5226
5227 attr = gfc_expr_attr (x);
5228
5229 if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
5230 && x->symtree->n.sym == x->symtree->n.sym->result)
8ba6ea87
ML		 5231 for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
5232 if (x->symtree->n.sym == ns->proc_name)
5233 {
5234 gfc_error ("Function result %qs at %L is invalid as X argument "
5235 "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
5236 return false;
5237 }
cadddfdd
TB		 5238
5239 if (attr.flavor != FL_PROCEDURE)
5240 {
5241 gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
5242 "or a procedure pointer", &x->where);
524af0d6 5243 return false;
cadddfdd
TB		 5244 }
5245
5246 if (!attr.is_bind_c)
286f737c 5247 return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
cadddfdd 5248 "at %L to C_FUNLOC", &x->where);
524af0d6 5249 return true;
cadddfdd
TB		 5250}
5251
5252
524af0d6 5253bool
cadddfdd
TB		 5254gfc_check_c_loc (gfc_expr *x)
5255{
5256 symbol_attribute attr;
5257 const char *msg;
5258
5259 if (gfc_is_coindexed (x))
5260 {
5261 gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
524af0d6 5262 return false;
cadddfdd
TB		 5263 }
5264
5265 if (x->ts.type == BT_CLASS)
5266 {
5267 gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
5268 &x->where);
524af0d6 5269 return false;
cadddfdd
TB		 5270 }
5271
5272 attr = gfc_expr_attr (x);
5273
5274 if (!attr.pointer
5275 && (x->expr_type != EXPR_VARIABLE || !attr.target
5276 || attr.flavor == FL_PARAMETER))
5277 {
5278 gfc_error ("Argument X at %L to C_LOC shall have either "
5279 "the POINTER or the TARGET attribute", &x->where);
524af0d6 5280 return false;
cadddfdd
TB		 5281 }
5282
5283 if (x->ts.type == BT_CHARACTER
5284 && gfc_var_strlen (x) == 0)
5285 {
5286 gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
5287 "string", &x->where);
524af0d6 5288 return false;
cadddfdd
TB		 5289 }
5290
5e7ea214 5291 if (!is_c_interoperable (x, &msg, true, false))
cadddfdd
TB		 5292 {
5293 if (x->ts.type == BT_CLASS)
5294 {
5295 gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
5296 &x->where);
524af0d6 5297 return false;
cadddfdd 5298 }
c7f587bd 5299
cadddfdd 5300 if (x->rank
286f737c 5301 && !gfc_notify_std (GFC_STD_F2018,
524af0d6
JB		 5302 "Noninteroperable array at %L as"
5303 " argument to C_LOC: %s", &x->where, msg))
5304 return false;
cadddfdd 5305 }
6082753e
TB		 5306 else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
5307 {
5308 gfc_array_ref *ar = gfc_find_array_ref (x);
5309
5310 if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
5311 && !attr.allocatable
c7f587bd 5312 && !gfc_notify_std (GFC_STD_F2008,
524af0d6
JB		 5313 "Array of interoperable type at %L "
5314 "to C_LOC which is nonallocatable and neither "
5315 "assumed size nor explicit size", &x->where))
5316 return false;
6082753e 5317 else if (ar->type != AR_FULL
524af0d6
JB		 5318 && !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
5319 "to C_LOC", &x->where))
5320 return false;
6082753e 5321 }
cadddfdd 5322
524af0d6 5323 return true;
048510c8
JW		 5324}
5325
5326
524af0d6 5327bool
65f8144a 5328gfc_check_sleep_sub (gfc_expr *seconds)
f77b6ca3 5329{
524af0d6
JB		 5330 if (!type_check (seconds, 0, BT_INTEGER))
5331 return false;
f77b6ca3 5332
524af0d6
JB		 5333 if (!scalar_check (seconds, 0))
5334 return false;
f77b6ca3 5335
524af0d6 5336 return true;
f77b6ca3
FXC		 5337}
5338
524af0d6 5339bool
c9018c71
DF		 5340gfc_check_sngl (gfc_expr *a)
5341{
524af0d6
JB		 5342 if (!type_check (a, 0, BT_REAL))
5343 return false;
c9018c71
DF		 5344
5345 if ((a->ts.kind != gfc_default_double_kind)
524af0d6 5346 && !gfc_notify_std (GFC_STD_GNU, "non double precision "
c7f587bd 5347 "REAL argument to %s intrinsic at %L",
524af0d6
JB		 5348 gfc_current_intrinsic, &a->where))
5349 return false;
c9018c71 5350
524af0d6 5351 return true;
c9018c71 5352}
f77b6ca3 5353
524af0d6 5354bool
65f8144a 5355gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
6de9cd9a 5356{
6de9cd9a
DN		 5357 if (source->rank >= GFC_MAX_DIMENSIONS)
5358 {
c4100eae 5359 gfc_error ("%qs argument of %qs intrinsic at %L must be less "
c4aa95f8 5360 "than rank %d", gfc_current_intrinsic_arg[0]->name,
4c93c95a 5361 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
31043f6c 5362
524af0d6 5363 return false;
6de9cd9a
DN		 5364 }
5365
7ab88654 5366 if (dim == NULL)
524af0d6 5367 return false;
7ab88654 5368
524af0d6
JB		 5369 if (!dim_check (dim, 1, false))
5370 return false;
6de9cd9a 5371
c430a6f9 5372 /* dim_rank_check() does not apply here. */
8b704316 5373 if (dim
c430a6f9
DF		 5374 && dim->expr_type == EXPR_CONSTANT
5375 && (mpz_cmp_ui (dim->value.integer, 1) < 0
5376 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
5377 {
c4100eae 5378 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
c4aa95f8 5379 "dimension index", gfc_current_intrinsic_arg[1]->name,
c430a6f9 5380 gfc_current_intrinsic, &dim->where);
524af0d6 5381 return false;
c430a6f9
DF		 5382 }
5383
524af0d6
JB		 5384 if (!type_check (ncopies, 2, BT_INTEGER))
5385 return false;
df65f093 5386
524af0d6
JB		 5387 if (!scalar_check (ncopies, 2))
5388 return false;
6de9cd9a 5389
524af0d6 5390 return true;
6de9cd9a
DN		 5391}
5392
5393
5d723e54
FXC		 5394/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
5395 functions). */
65f8144a 5396
524af0d6 5397bool
65f8144a 5398gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
5d723e54 5399{
524af0d6
JB		 5400 if (!type_check (unit, 0, BT_INTEGER))
5401 return false;
5d723e54 5402
524af0d6
JB		 5403 if (!scalar_check (unit, 0))
5404 return false;
5d723e54 5405
524af0d6
JB		 5406 if (!type_check (c, 1, BT_CHARACTER))
5407 return false;
5408 if (!kind_value_check (c, 1, gfc_default_character_kind))
5409 return false;
5d723e54
FXC		 5410
5411 if (status == NULL)
524af0d6 5412 return true;
5d723e54 5413
524af0d6
JB		 5414 if (!type_check (status, 2, BT_INTEGER)
5415 || !kind_value_check (status, 2, gfc_default_integer_kind)
5416 || !scalar_check (status, 2))
5417 return false;
5d723e54 5418
524af0d6 5419 return true;
5d723e54
FXC		 5420}
5421
5422
524af0d6 5423bool
65f8144a 5424gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
5d723e54
FXC		 5425{
5426 return gfc_check_fgetputc_sub (unit, c, NULL);
5427}
5428
5429
524af0d6 5430bool
65f8144a 5431gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
5d723e54 5432{
524af0d6
JB		 5433 if (!type_check (c, 0, BT_CHARACTER))
5434 return false;
5435 if (!kind_value_check (c, 0, gfc_default_character_kind))
5436 return false;
5d723e54
FXC		 5437
5438 if (status == NULL)
524af0d6 5439 return true;
5d723e54 5440
524af0d6
JB		 5441 if (!type_check (status, 1, BT_INTEGER)
5442 || !kind_value_check (status, 1, gfc_default_integer_kind)
5443 || !scalar_check (status, 1))
5444 return false;
5d723e54 5445
524af0d6 5446 return true;
5d723e54
FXC		 5447}
5448
5449
524af0d6 5450bool
65f8144a 5451gfc_check_fgetput (gfc_expr *c)
5d723e54
FXC		 5452{
5453 return gfc_check_fgetput_sub (c, NULL);
5454}
5455
5456
524af0d6 5457bool
dcdc26df
DF		 5458gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
5459{
524af0d6
JB		 5460 if (!type_check (unit, 0, BT_INTEGER))
5461 return false;
dcdc26df 5462
524af0d6
JB		 5463 if (!scalar_check (unit, 0))
5464 return false;
dcdc26df 5465
524af0d6
JB		 5466 if (!type_check (offset, 1, BT_INTEGER))
5467 return false;
dcdc26df 5468
524af0d6
JB		 5469 if (!scalar_check (offset, 1))
5470 return false;
dcdc26df 5471
524af0d6
JB		 5472 if (!type_check (whence, 2, BT_INTEGER))
5473 return false;
dcdc26df 5474
524af0d6
JB		 5475 if (!scalar_check (whence, 2))
5476 return false;
dcdc26df
DF		 5477
5478 if (status == NULL)
524af0d6 5479 return true;
dcdc26df 5480
524af0d6
JB		 5481 if (!type_check (status, 3, BT_INTEGER))
5482 return false;
dcdc26df 5483
524af0d6
JB		 5484 if (!kind_value_check (status, 3, 4))
5485 return false;
dcdc26df 5486
524af0d6
JB		 5487 if (!scalar_check (status, 3))
5488 return false;
dcdc26df 5489
524af0d6 5490 return true;
dcdc26df
DF		 5491}
5492
5493
5494
524af0d6 5495bool
65f8144a 5496gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
df65f093 5497{
524af0d6
JB		 5498 if (!type_check (unit, 0, BT_INTEGER))
5499 return false;
df65f093 5500
524af0d6
JB		 5501 if (!scalar_check (unit, 0))
5502 return false;
df65f093 5503
524af0d6
JB		 5504 if (!type_check (array, 1, BT_INTEGER)
5505 || !kind_value_check (unit, 0, gfc_default_integer_kind))
5506 return false;
df65f093 5507
524af0d6
JB		 5508 if (!array_check (array, 1))
5509 return false;
df65f093 5510
524af0d6 5511 return true;
df65f093
SK		 5512}
5513
5514
524af0d6 5515bool
65f8144a 5516gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
df65f093 5517{
524af0d6
JB		 5518 if (!type_check (unit, 0, BT_INTEGER))
5519 return false;
df65f093 5520
524af0d6
JB		 5521 if (!scalar_check (unit, 0))
5522 return false;
df65f093 5523
524af0d6
JB		 5524 if (!type_check (array, 1, BT_INTEGER)
5525 || !kind_value_check (array, 1, gfc_default_integer_kind))
5526 return false;
df65f093 5527
524af0d6
JB		 5528 if (!array_check (array, 1))
5529 return false;
df65f093
SK		 5530
5531 if (status == NULL)
524af0d6 5532 return true;
df65f093 5533
524af0d6
JB		 5534 if (!type_check (status, 2, BT_INTEGER)
5535 || !kind_value_check (status, 2, gfc_default_integer_kind))
5536 return false;
df65f093 5537
524af0d6
JB		 5538 if (!scalar_check (status, 2))
5539 return false;
df65f093 5540
524af0d6 5541 return true;
df65f093
SK		 5542}
5543
5544
524af0d6 5545bool
65f8144a 5546gfc_check_ftell (gfc_expr *unit)
5d723e54 5547{
524af0d6
JB		 5548 if (!type_check (unit, 0, BT_INTEGER))
5549 return false;
5d723e54 5550
524af0d6
JB		 5551 if (!scalar_check (unit, 0))
5552 return false;
5d723e54 5553
524af0d6 5554 return true;
5d723e54
FXC		 5555}
5556
5557
524af0d6 5558bool
65f8144a 5559gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
5d723e54 5560{
524af0d6
JB		 5561 if (!type_check (unit, 0, BT_INTEGER))
5562 return false;
5d723e54 5563
524af0d6
JB		 5564 if (!scalar_check (unit, 0))
5565 return false;
5d723e54 5566
524af0d6
JB		 5567 if (!type_check (offset, 1, BT_INTEGER))
5568 return false;
5d723e54 5569
524af0d6
JB		 5570 if (!scalar_check (offset, 1))
5571 return false;
5d723e54 5572
524af0d6 5573 return true;
5d723e54
FXC		 5574}
5575
5576
524af0d6 5577bool
65f8144a 5578gfc_check_stat (gfc_expr *name, gfc_expr *array)
df65f093 5579{
524af0d6
JB		 5580 if (!type_check (name, 0, BT_CHARACTER))
5581 return false;
5582 if (!kind_value_check (name, 0, gfc_default_character_kind))
5583 return false;
df65f093 5584
524af0d6
JB		 5585 if (!type_check (array, 1, BT_INTEGER)
5586 || !kind_value_check (array, 1, gfc_default_integer_kind))
5587 return false;
df65f093 5588
524af0d6
JB		 5589 if (!array_check (array, 1))
5590 return false;
df65f093 5591
524af0d6 5592 return true;
df65f093
SK		 5593}
5594
5595
524af0d6 5596bool
65f8144a 5597gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
df65f093 5598{
524af0d6
JB		 5599 if (!type_check (name, 0, BT_CHARACTER))
5600 return false;
5601 if (!kind_value_check (name, 0, gfc_default_character_kind))
5602 return false;
df65f093 5603
524af0d6
JB		 5604 if (!type_check (array, 1, BT_INTEGER)
5605 || !kind_value_check (array, 1, gfc_default_integer_kind))
5606 return false;
df65f093 5607
524af0d6
JB		 5608 if (!array_check (array, 1))
5609 return false;
df65f093
SK		 5610
5611 if (status == NULL)
524af0d6 5612 return true;
df65f093 5613
524af0d6
JB		 5614 if (!type_check (status, 2, BT_INTEGER)
5615 || !kind_value_check (array, 1, gfc_default_integer_kind))
5616 return false;
df65f093 5617
524af0d6
JB		 5618 if (!scalar_check (status, 2))
5619 return false;
df65f093 5620
524af0d6 5621 return true;
df65f093
SK		 5622}
5623
5624
524af0d6 5625bool
64f002ed
TB		 5626gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
5627{
e84b920c
TB		 5628 mpz_t nelems;
5629
f19626cf 5630 if (flag_coarray == GFC_FCOARRAY_NONE)
64f002ed 5631 {
ddc05d11 5632 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
524af0d6 5633 return false;
64f002ed
TB		 5634 }
5635
524af0d6
JB		 5636 if (!coarray_check (coarray, 0))
5637 return false;
64f002ed
TB		 5638
5639 if (sub->rank != 1)
5640 {
5641 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
c4aa95f8 5642 gfc_current_intrinsic_arg[1]->name, &sub->where);
524af0d6 5643 return false;
64f002ed
TB		 5644 }
5645
524af0d6 5646 if (gfc_array_size (sub, &nelems))
e84b920c
TB		 5647 {
5648 int corank = gfc_get_corank (coarray);
5649
5650 if (mpz_cmp_ui (nelems, corank) != 0)
5651 {
5652 gfc_error ("The number of array elements of the SUB argument to "
5653 "IMAGE_INDEX at %L shall be %d (corank) not %d",
5654 &sub->where, corank, (int) mpz_get_si (nelems));
5655 mpz_clear (nelems);
524af0d6 5656 return false;
e84b920c
TB		 5657 }
5658 mpz_clear (nelems);
5659 }
5660
524af0d6 5661 return true;
64f002ed
TB		 5662}
5663
5664
524af0d6 5665bool
05fc16dd 5666gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
64f002ed 5667{
f19626cf 5668 if (flag_coarray == GFC_FCOARRAY_NONE)
64f002ed 5669 {
ddc05d11 5670 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
524af0d6 5671 return false;
64f002ed
TB		 5672 }
5673
05fc16dd 5674 if (distance)
64f002ed 5675 {
05fc16dd
TB		 5676 if (!type_check (distance, 0, BT_INTEGER))
5677 return false;
5678
5679 if (!nonnegative_check ("DISTANCE", distance))
5680 return false;
5681
5682 if (!scalar_check (distance, 0))
5683 return false;
5684
286f737c 5685 if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
05fc16dd
TB		 5686 "NUM_IMAGES at %L", &distance->where))
5687 return false;
5688 }
5689
5690 if (failed)
5691 {
5692 if (!type_check (failed, 1, BT_LOGICAL))
5693 return false;
5694
5695 if (!scalar_check (failed, 1))
5696 return false;
5697
286f737c 5698 if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to "
57b1c5e9 5699 "NUM_IMAGES at %L", &failed->where))
05fc16dd
TB		 5700 return false;
5701 }
5702
5703 return true;
5704}
5705
5706
f8862a1b
DR		 5707bool
5708gfc_check_team_number (gfc_expr *team)
5709{
5710 if (flag_coarray == GFC_FCOARRAY_NONE)
5711 {
5712 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5713 return false;
5714 }
5715
5716 if (team)
5717 {
5718 if (team->ts.type != BT_DERIVED
5719 || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
5720 || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
5721 {
5722 gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
5723 "shall be of type TEAM_TYPE", &team->where);
5724 return false;
5725 }
5726 }
5727 else
5728 return true;
5729
5730 return true;
5731}
5732
5733
05fc16dd
TB		 5734bool
5735gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
5736{
f19626cf 5737 if (flag_coarray == GFC_FCOARRAY_NONE)
05fc16dd 5738 {
ddc05d11 5739 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
524af0d6 5740 return false;
64f002ed
TB		 5741 }
5742
05fc16dd 5743 if (coarray == NULL && dim == NULL && distance == NULL)
524af0d6 5744 return true;
64f002ed 5745
05fc16dd
TB		 5746 if (dim != NULL && coarray == NULL)
5747 {
5748 gfc_error ("DIM argument without COARRAY argument not allowed for "
5749 "THIS_IMAGE intrinsic at %L", &dim->where);
5750 return false;
5751 }
5752
5753 if (distance && (coarray || dim))
5754 {
5755 gfc_error ("The DISTANCE argument may not be specified together with the "
5756 "COARRAY or DIM argument in intrinsic at %L",
5757 &distance->where);
5758 return false;
5759 }
5760
5761 /* Assume that we have "this_image (distance)". */
5762 if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
5763 {
5764 if (dim)
5765 {
5766 gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
5767 &coarray->where);
5768 return false;
5769 }
5770 distance = coarray;
5771 }
5772
5773 if (distance)
5774 {
5775 if (!type_check (distance, 2, BT_INTEGER))
5776 return false;
5777
5778 if (!nonnegative_check ("DISTANCE", distance))
5779 return false;
5780
5781 if (!scalar_check (distance, 2))
5782 return false;
5783
286f737c 5784 if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
05fc16dd
TB		 5785 "THIS_IMAGE at %L", &distance->where))
5786 return false;
5787
5788 return true;
5789 }
5790
524af0d6
JB		 5791 if (!coarray_check (coarray, 0))
5792 return false;
64f002ed
TB		 5793
5794 if (dim != NULL)
5795 {
524af0d6
JB		 5796 if (!dim_check (dim, 1, false))
5797 return false;
64f002ed 5798
524af0d6
JB		 5799 if (!dim_corank_check (dim, coarray))
5800 return false;
64f002ed
TB		 5801 }
5802
524af0d6 5803 return true;
64f002ed
TB		 5804}
5805
86dbed7d 5806/* Calculate the sizes for transfer, used by gfc_check_transfer and also
524af0d6 5807 by gfc_simplify_transfer. Return false if we cannot do so. */
64f002ed 5808
524af0d6 5809bool
86dbed7d
TK		 5810gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
5811 size_t *source_size, size_t *result_size,
5812 size_t *result_length_p)
86dbed7d
TK		 5813{
5814 size_t result_elt_size;
86dbed7d
TK		 5815
5816 if (source->expr_type == EXPR_FUNCTION)
524af0d6 5817 return false;
86dbed7d 5818
9a575e05 5819 if (size && size->expr_type != EXPR_CONSTANT)
524af0d6 5820 return false;
9a575e05
TB		 5821
5822 /* Calculate the size of the source. */
cdd17931 5823 if (!gfc_target_expr_size (source, source_size))
524af0d6 5824 return false;
86dbed7d 5825
86dbed7d 5826 /* Determine the size of the element. */
cdd17931 5827 if (!gfc_element_size (mold, &result_elt_size))
524af0d6 5828 return false;
86dbed7d 5829
4716603b
HA		 5830 /* If the storage size of SOURCE is greater than zero and MOLD is an array,
5831 * a scalar with the type and type parameters of MOLD shall not have a
5832 * storage size equal to zero.
5833 * If MOLD is a scalar and SIZE is absent, the result is a scalar.
5834 * If MOLD is an array and SIZE is absent, the result is an array and of
5835 * rank one. Its size is as small as possible such that its physical
5836 * representation is not shorter than that of SOURCE.
5837 * If SIZE is present, the result is an array of rank one and size SIZE.
5838 */
5839 if (result_elt_size == 0 && *source_size > 0 && !size
5840 && mold->expr_type == EXPR_ARRAY)
ec2d749a 5841 {
4716603b
HA		 5842 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
5843 "array and shall not have storage size 0 when %<SOURCE%> "
ec2d749a
HA		 5844 "argument has size greater than 0", &mold->where);
5845 return false;
5846 }
5847
ec2d749a
HA		 5848 if (result_elt_size == 0 && *source_size == 0 && !size)
5849 {
5850 *result_size = 0;
4716603b
HA		 5851 if (result_length_p)
5852 *result_length_p = 0;
ec2d749a
HA		 5853 return true;
5854 }
5855
cdd17931
HA		 5856 if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank))
5857 || size)
86dbed7d
TK		 5858 {
5859 int result_length;
5860
5861 if (size)
5862 result_length = (size_t)mpz_get_ui (size->value.integer);
5863 else
5864 {
5865 result_length = *source_size / result_elt_size;
5866 if (result_length * result_elt_size < *source_size)
5867 result_length += 1;
5868 }
5869
5870 *result_size = result_length * result_elt_size;
5871 if (result_length_p)
5872 *result_length_p = result_length;
5873 }
5874 else
5875 *result_size = result_elt_size;
5876
524af0d6 5877 return true;
86dbed7d
TK		 5878}
5879
5880
524af0d6 5881bool
86dbed7d 5882gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
6de9cd9a 5883{
86dbed7d
TK		 5884 size_t source_size;
5885 size_t result_size;
5886
aace91e2
HA		 5887 /* SOURCE shall be a scalar or array of any type. */
5888 if (source->ts.type == BT_PROCEDURE
5889 && source->symtree->n.sym->attr.subroutine == 1)
5890 {
5891 gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
5892 "must not be a %s", &source->where,
5893 gfc_basic_typename (source->ts.type));
5894 return false;
5895 }
5896
5897 /* MOLD shall be a scalar or array of any type. */
5898 if (mold->ts.type == BT_PROCEDURE
5899 && mold->symtree->n.sym->attr.subroutine == 1)
5900 {
5901 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
5902 "must not be a %s", &mold->where,
5903 gfc_basic_typename (mold->ts.type));
5904 return false;
5905 }
5906
3b45d6c4
BM		 5907 if (mold->ts.type == BT_HOLLERITH)
5908 {
a4d9b221
TB		 5909 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
5910 " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
524af0d6 5911 return false;
3b45d6c4
BM		 5912 }
5913
aace91e2
HA		 5914 /* SIZE (optional) shall be an integer scalar. The corresponding actual
5915 argument shall not be an optional dummy argument. */
6de9cd9a
DN		 5916 if (size != NULL)
5917 {
524af0d6
JB		 5918 if (!type_check (size, 2, BT_INTEGER))
5919 return false;
6de9cd9a 5920
524af0d6
JB		 5921 if (!scalar_check (size, 2))
5922 return false;
6de9cd9a 5923
524af0d6
JB		 5924 if (!nonoptional_check (size, 2))
5925 return false;
6de9cd9a
DN		 5926 }
5927
73e42eef 5928 if (!warn_surprising)
524af0d6 5929 return true;
86dbed7d
TK		 5930
5931 /* If we can't calculate the sizes, we cannot check any more.
524af0d6 5932 Return true for that case. */
86dbed7d 5933
c7f587bd 5934 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
524af0d6
JB		 5935 &result_size, NULL))
5936 return true;
86dbed7d
TK		 5937
5938 if (source_size < result_size)
28ce22e6
JW		 5939 gfc_warning (OPT_Wsurprising,
5940 "Intrinsic TRANSFER at %L has partly undefined result: "
48749dbc
MLI		 5941 "source size %ld < result size %ld", &source->where,
5942 (long) source_size, (long) result_size);
86dbed7d 5943
524af0d6 5944 return true;
6de9cd9a
DN		 5945}
5946
5947
524af0d6 5948bool
65f8144a 5949gfc_check_transpose (gfc_expr *matrix)
6de9cd9a 5950{
524af0d6
JB		 5951 if (!rank_check (matrix, 0, 2))
5952 return false;
6de9cd9a 5953
524af0d6 5954 return true;
6de9cd9a
DN		 5955}
5956
5957
524af0d6 5958bool
5cda5098 5959gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6de9cd9a 5960{
524af0d6
JB		 5961 if (!array_check (array, 0))
5962 return false;
6de9cd9a 5963
524af0d6
JB		 5964 if (!dim_check (dim, 1, false))
5965 return false;
6de9cd9a 5966
524af0d6
JB		 5967 if (!dim_rank_check (dim, array, 0))
5968 return false;
27dfc9c4 5969
524af0d6
JB		 5970 if (!kind_check (kind, 2, BT_INTEGER))
5971 return false;
a4d9b221 5972 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 5973 "with KIND argument at %L",
524af0d6
JB		 5974 gfc_current_intrinsic, &kind->where))
5975 return false;
64f002ed 5976
524af0d6 5977 return true;
64f002ed
TB		 5978}
5979
5980
524af0d6 5981bool
64f002ed
TB		 5982gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
5983{
f19626cf 5984 if (flag_coarray == GFC_FCOARRAY_NONE)
64f002ed 5985 {
ddc05d11 5986 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
524af0d6 5987 return false;
64f002ed
TB		 5988 }
5989
524af0d6
JB		 5990 if (!coarray_check (coarray, 0))
5991 return false;
64f002ed
TB		 5992
5993 if (dim != NULL)
5994 {
524af0d6
JB		 5995 if (!dim_check (dim, 1, false))
5996 return false;
64f002ed 5997
524af0d6
JB		 5998 if (!dim_corank_check (dim, coarray))
5999 return false;
64f002ed
TB		 6000 }
6001
524af0d6
JB		 6002 if (!kind_check (kind, 2, BT_INTEGER))
6003 return false;
5cda5098 6004
524af0d6 6005 return true;
6de9cd9a
DN		 6006}
6007
6008
524af0d6 6009bool
65f8144a 6010gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6de9cd9a 6011{
c430a6f9
DF		 6012 mpz_t vector_size;
6013
524af0d6
JB		 6014 if (!rank_check (vector, 0, 1))
6015 return false;
6de9cd9a 6016
524af0d6
JB		 6017 if (!array_check (mask, 1))
6018 return false;
6de9cd9a 6019
524af0d6
JB		 6020 if (!type_check (mask, 1, BT_LOGICAL))
6021 return false;
6de9cd9a 6022
524af0d6
JB		 6023 if (!same_type_check (vector, 0, field, 2))
6024 return false;
6de9cd9a 6025
c430a6f9 6026 if (mask->expr_type == EXPR_ARRAY
524af0d6 6027 && gfc_array_size (vector, &vector_size))
c430a6f9
DF		 6028 {
6029 int mask_true_count = 0;
b7e75771
JD		 6030 gfc_constructor *mask_ctor;
6031 mask_ctor = gfc_constructor_first (mask->value.constructor);
c430a6f9
DF		 6032 while (mask_ctor)
6033 {
6034 if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
6035 {
6036 mask_true_count = 0;
6037 break;
6038 }
6039
6040 if (mask_ctor->expr->value.logical)
6041 mask_true_count++;
6042
b7e75771 6043 mask_ctor = gfc_constructor_next (mask_ctor);
c430a6f9
DF		 6044 }
6045
6046 if (mpz_get_si (vector_size) < mask_true_count)
6047 {
c4100eae 6048 gfc_error ("%qs argument of %qs intrinsic at %L must "
c430a6f9 6049 "provide at least as many elements as there "
c4100eae 6050 "are .TRUE. values in %qs (%ld/%d)",
c4aa95f8
JW		 6051 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
6052 &vector->where, gfc_current_intrinsic_arg[1]->name,
c430a6f9 6053 mpz_get_si (vector_size), mask_true_count);
524af0d6 6054 return false;
c430a6f9
DF		 6055 }
6056
6057 mpz_clear (vector_size);
6058 }
6059
d1a296c1
TB		 6060 if (mask->rank != field->rank && field->rank != 0)
6061 {
c4100eae
MLI		 6062 gfc_error ("%qs argument of %qs intrinsic at %L must have "
6063 "the same rank as %qs or be a scalar",
c4aa95f8
JW		 6064 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
6065 &field->where, gfc_current_intrinsic_arg[1]->name);
524af0d6 6066 return false;
d1a296c1
TB		 6067 }
6068
6069 if (mask->rank == field->rank)
6070 {
6071 int i;
6072 for (i = 0; i < field->rank; i++)
6073 if (! identical_dimen_shape (mask, i, field, i))
6074 {
c4100eae 6075 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
8b704316 6076 "must have identical shape.",
c4aa95f8
JW		 6077 gfc_current_intrinsic_arg[2]->name,
6078 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
c430a6f9 6079 &field->where);
d1a296c1
TB		 6080 }
6081 }
6082
524af0d6 6083 return true;
6de9cd9a
DN		 6084}
6085
6086
524af0d6 6087bool
5cda5098 6088gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
6de9cd9a 6089{
524af0d6
JB		 6090 if (!type_check (x, 0, BT_CHARACTER))
6091 return false;
6de9cd9a 6092
524af0d6
JB		 6093 if (!same_type_check (x, 0, y, 1))
6094 return false;
6de9cd9a 6095
524af0d6
JB		 6096 if (z != NULL && !type_check (z, 2, BT_LOGICAL))
6097 return false;
6de9cd9a 6098
524af0d6
JB		 6099 if (!kind_check (kind, 3, BT_INTEGER))
6100 return false;
a4d9b221 6101 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
c7f587bd 6102 "with KIND argument at %L",
524af0d6
JB		 6103 gfc_current_intrinsic, &kind->where))
6104 return false;
5cda5098 6105
524af0d6 6106 return true;
6de9cd9a
DN		 6107}
6108
6109
524af0d6 6110bool
65f8144a 6111gfc_check_trim (gfc_expr *x)
6de9cd9a 6112{
524af0d6
JB		 6113 if (!type_check (x, 0, BT_CHARACTER))
6114 return false;
6de9cd9a 6115
524af0d6
JB		 6116 if (!scalar_check (x, 0))
6117 return false;
6de9cd9a 6118
524af0d6 6119 return true;
6de9cd9a
DN		 6120}
6121
6122
524af0d6 6123bool
65f8144a 6124gfc_check_ttynam (gfc_expr *unit)
25fc05eb 6125{
524af0d6
JB		 6126 if (!scalar_check (unit, 0))
6127 return false;
25fc05eb 6128
524af0d6
JB		 6129 if (!type_check (unit, 0, BT_INTEGER))
6130 return false;
25fc05eb 6131
524af0d6 6132 return true;
25fc05eb
FXC		 6133}
6134
6135
6de9cd9a
DN		 6136/************* Check functions for intrinsic subroutines *************/
6137
524af0d6 6138bool
65f8144a 6139gfc_check_cpu_time (gfc_expr *time)
6de9cd9a 6140{
524af0d6
JB		 6141 if (!scalar_check (time, 0))
6142 return false;
6de9cd9a 6143
524af0d6
JB		 6144 if (!type_check (time, 0, BT_REAL))
6145 return false;
6de9cd9a 6146
524af0d6
JB		 6147 if (!variable_check (time, 0, false))
6148 return false;
6de9cd9a 6149
524af0d6 6150 return true;
6de9cd9a
DN		 6151}
6152
6153
524af0d6 6154bool
65f8144a
SK		 6155gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
6156 gfc_expr *zone, gfc_expr *values)
6de9cd9a 6157{
6de9cd9a
DN		 6158 if (date != NULL)
6159 {
524af0d6
JB		 6160 if (!type_check (date, 0, BT_CHARACTER))
6161 return false;
6162 if (!kind_value_check (date, 0, gfc_default_character_kind))
6163 return false;
6164 if (!scalar_check (date, 0))
6165 return false;
6166 if (!variable_check (date, 0, false))
6167 return false;
6de9cd9a
DN		 6168 }
6169
6170 if (time != NULL)
6171 {
524af0d6
JB		 6172 if (!type_check (time, 1, BT_CHARACTER))
6173 return false;
6174 if (!kind_value_check (time, 1, gfc_default_character_kind))
6175 return false;
6176 if (!scalar_check (time, 1))
6177 return false;
6178 if (!variable_check (time, 1, false))
6179 return false;
6de9cd9a
DN		 6180 }
6181
6182 if (zone != NULL)
6183 {
524af0d6
JB		 6184 if (!type_check (zone, 2, BT_CHARACTER))
6185 return false;
6186 if (!kind_value_check (zone, 2, gfc_default_character_kind))
6187 return false;
6188 if (!scalar_check (zone, 2))
6189 return false;
6190 if (!variable_check (zone, 2, false))
6191 return false;
6de9cd9a
DN		 6192 }
6193
6194 if (values != NULL)
6195 {
524af0d6
JB		 6196 if (!type_check (values, 3, BT_INTEGER))
6197 return false;
6198 if (!array_check (values, 3))
6199 return false;
6200 if (!rank_check (values, 3, 1))
6201 return false;
6202 if (!variable_check (values, 3, false))
6203 return false;
6de9cd9a
DN		 6204 }
6205
524af0d6 6206 return true;
6de9cd9a
DN		 6207}
6208
6209
524af0d6 6210bool
65f8144a
SK		 6211gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
6212 gfc_expr *to, gfc_expr *topos)
6de9cd9a 6213{
524af0d6
JB		 6214 if (!type_check (from, 0, BT_INTEGER))
6215 return false;
6de9cd9a 6216
524af0d6
JB		 6217 if (!type_check (frompos, 1, BT_INTEGER))
6218 return false;
6de9cd9a 6219
524af0d6
JB		 6220 if (!type_check (len, 2, BT_INTEGER))
6221 return false;
6de9cd9a 6222
524af0d6
JB		 6223 if (!same_type_check (from, 0, to, 3))
6224 return false;
6de9cd9a 6225
524af0d6
JB		 6226 if (!variable_check (to, 3, false))
6227 return false;
6de9cd9a 6228
524af0d6
JB		 6229 if (!type_check (topos, 4, BT_INTEGER))
6230 return false;
6de9cd9a 6231
524af0d6
JB		 6232 if (!nonnegative_check ("frompos", frompos))
6233 return false;
289e52fd 6234
524af0d6
JB		 6235 if (!nonnegative_check ("topos", topos))
6236 return false;
289e52fd 6237
524af0d6
JB		 6238 if (!nonnegative_check ("len", len))
6239 return false;
289e52fd 6240
524af0d6
JB		 6241 if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len))
6242 return false;
289e52fd 6243
524af0d6
JB		 6244 if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len))
6245 return false;
289e52fd 6246
524af0d6 6247 return true;
6de9cd9a
DN		 6248}
6249
6250
ddd3e26e
SK		 6251/* Check the arguments for RANDOM_INIT. */
6252
6253bool
6254gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
6255{
6256 if (!type_check (repeatable, 0, BT_LOGICAL))
6257 return false;
6258
6259 if (!scalar_check (repeatable, 0))
6260 return false;
6261
6262 if (!type_check (image_distinct, 1, BT_LOGICAL))
6263 return false;
6264
6265 if (!scalar_check (image_distinct, 1))
6266 return false;
6267
6268 return true;
6269}
6270
6271
524af0d6 6272bool
65f8144a 6273gfc_check_random_number (gfc_expr *harvest)
6de9cd9a 6274{
524af0d6
JB		 6275 if (!type_check (harvest, 0, BT_REAL))
6276 return false;
6de9cd9a 6277
524af0d6
JB		 6278 if (!variable_check (harvest, 0, false))
6279 return false;
6de9cd9a 6280
524af0d6 6281 return true;
6de9cd9a
DN		 6282}
6283
6284
524af0d6 6285bool
65f8144a 6286gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
6de9cd9a 6287{
b152f5a2 6288 unsigned int nargs = 0, seed_size;
34b4bc5c 6289 locus *where = NULL;
b55c4f04 6290 mpz_t put_size, get_size;
34b4bc5c 6291
b152f5a2
JB		 6292 /* Keep the number of bytes in sync with master_state in
6293 libgfortran/intrinsics/random.c. +1 due to the integer p which is
6294 part of the state too. */
6295 seed_size = 128 / gfc_default_integer_kind + 1;
b55c4f04 6296
6de9cd9a
DN		 6297 if (size != NULL)
6298 {
34b4bc5c
FXC		 6299 if (size->expr_type != EXPR_VARIABLE
6300 || !size->symtree->n.sym->attr.optional)
6301 nargs++;
6302
524af0d6
JB		 6303 if (!scalar_check (size, 0))
6304 return false;
6de9cd9a 6305
524af0d6
JB		 6306 if (!type_check (size, 0, BT_INTEGER))
6307 return false;
6de9cd9a 6308
524af0d6
JB		 6309 if (!variable_check (size, 0, false))
6310 return false;
6de9cd9a 6311
524af0d6
JB		 6312 if (!kind_value_check (size, 0, gfc_default_integer_kind))
6313 return false;
6de9cd9a
DN		 6314 }
6315
6316 if (put != NULL)
6317 {
34b4bc5c
FXC		 6318 if (put->expr_type != EXPR_VARIABLE
6319 || !put->symtree->n.sym->attr.optional)
6320 {
6321 nargs++;
6322 where = &put->where;
6323 }
95d3f567 6324
524af0d6
JB		 6325 if (!array_check (put, 1))
6326 return false;
95d3f567 6327
524af0d6
JB		 6328 if (!rank_check (put, 1, 1))
6329 return false;
6de9cd9a 6330
524af0d6
JB		 6331 if (!type_check (put, 1, BT_INTEGER))
6332 return false;
6de9cd9a 6333
524af0d6
JB		 6334 if (!kind_value_check (put, 1, gfc_default_integer_kind))
6335 return false;
1b867ae7 6336
524af0d6 6337 if (gfc_array_size (put, &put_size)
b152f5a2 6338 && mpz_get_ui (put_size) < seed_size)
c4100eae 6339 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
b55c4f04 6340 "too small (%i/%i)",
c4aa95f8 6341 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
b152f5a2 6342 where, (int) mpz_get_ui (put_size), seed_size);
6de9cd9a
DN		 6343 }
6344
6345 if (get != NULL)
6346 {
34b4bc5c
FXC		 6347 if (get->expr_type != EXPR_VARIABLE
6348 || !get->symtree->n.sym->attr.optional)
6349 {
6350 nargs++;
6351 where = &get->where;
6352 }
95d3f567 6353
524af0d6
JB		 6354 if (!array_check (get, 2))
6355 return false;
95d3f567 6356
524af0d6
JB		 6357 if (!rank_check (get, 2, 1))
6358 return false;
6de9cd9a 6359
524af0d6
JB		 6360 if (!type_check (get, 2, BT_INTEGER))
6361 return false;
6de9cd9a 6362
524af0d6
JB		 6363 if (!variable_check (get, 2, false))
6364 return false;
6de9cd9a 6365
524af0d6
JB		 6366 if (!kind_value_check (get, 2, gfc_default_integer_kind))
6367 return false;
b55c4f04 6368
524af0d6 6369 if (gfc_array_size (get, &get_size)
b152f5a2 6370 && mpz_get_ui (get_size) < seed_size)
c4100eae 6371 gfc_error ("Size of %qs argument of %qs intrinsic at %L "
b55c4f04 6372 "too small (%i/%i)",
c4aa95f8 6373 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
b152f5a2 6374 where, (int) mpz_get_ui (get_size), seed_size);
6de9cd9a
DN		 6375 }
6376
34b4bc5c
FXC		 6377 /* RANDOM_SEED may not have more than one non-optional argument. */
6378 if (nargs > 1)
6379 gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
6380
524af0d6 6381 return true;
6de9cd9a 6382}
21fdfcc1 6383
f1abbf69
TK		 6384bool
6385gfc_check_fe_runtime_error (gfc_actual_arglist *a)
6386{
6387 gfc_expr *e;
6b271a2e 6388 size_t len, i;
f1abbf69
TK		 6389 int num_percent, nargs;
6390
6391 e = a->expr;
6392 if (e->expr_type != EXPR_CONSTANT)
6393 return true;
6394
6395 len = e->value.character.length;
6396 if (e->value.character.string[len-1] != '\0')
6397 gfc_internal_error ("fe_runtime_error string must be null terminated");
6398
6399 num_percent = 0;
6400 for (i=0; i<len-1; i++)
6401 if (e->value.character.string[i] == '%')
6402 num_percent ++;
6403
6404 nargs = 0;
6405 for (; a; a = a->next)
6406 nargs ++;
6407
6408 if (nargs -1 != num_percent)
6409 gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
6410 nargs, num_percent++);
6411
6412 return true;
6413}
65f8144a 6414
524af0d6 6415bool
65f8144a 6416gfc_check_second_sub (gfc_expr *time)
2bd74949 6417{
524af0d6
JB		 6418 if (!scalar_check (time, 0))
6419 return false;
2bd74949 6420
524af0d6
JB		 6421 if (!type_check (time, 0, BT_REAL))
6422 return false;
2bd74949 6423
524af0d6
JB		 6424 if (!kind_value_check (time, 0, 4))
6425 return false;
2bd74949 6426
524af0d6 6427 return true;
2bd74949
SK		 6428}
6429
6430
a416c4c7
FXC		 6431/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
6432 variables in Fortran 95. In Fortran 2003 and later, they can be of any
6433 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
6434 count_max are all optional arguments */
21fdfcc1 6435
524af0d6 6436bool
65f8144a
SK		 6437gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
6438 gfc_expr *count_max)
21fdfcc1 6439{
21fdfcc1
SK		 6440 if (count != NULL)
6441 {
524af0d6
JB		 6442 if (!scalar_check (count, 0))
6443 return false;
21fdfcc1 6444
524af0d6
JB		 6445 if (!type_check (count, 0, BT_INTEGER))
6446 return false;
21fdfcc1 6447
a416c4c7
FXC		 6448 if (count->ts.kind != gfc_default_integer_kind
6449 && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
6450 "SYSTEM_CLOCK at %L has non-default kind",
6451 &count->where))
6452 return false;
6453
524af0d6
JB		 6454 if (!variable_check (count, 0, false))
6455 return false;
21fdfcc1
SK		 6456 }
6457
6458 if (count_rate != NULL)
6459 {
524af0d6
JB		 6460 if (!scalar_check (count_rate, 1))
6461 return false;
21fdfcc1 6462
524af0d6
JB		 6463 if (!variable_check (count_rate, 1, false))
6464 return false;
21fdfcc1 6465
a416c4c7
FXC		 6466 if (count_rate->ts.type == BT_REAL)
6467 {
6468 if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
6469 "SYSTEM_CLOCK at %L", &count_rate->where))
6470 return false;
6471 }
6472 else
6473 {
6474 if (!type_check (count_rate, 1, BT_INTEGER))
6475 return false;
6476
6477 if (count_rate->ts.kind != gfc_default_integer_kind
6478 && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
6479 "SYSTEM_CLOCK at %L has non-default kind",
6480 &count_rate->where))
6481 return false;
6482 }
21fdfcc1
SK		 6483
6484 }
6485
6486 if (count_max != NULL)
6487 {
524af0d6
JB		 6488 if (!scalar_check (count_max, 2))
6489 return false;
21fdfcc1 6490
524af0d6
JB		 6491 if (!type_check (count_max, 2, BT_INTEGER))
6492 return false;
21fdfcc1 6493
a416c4c7
FXC		 6494 if (count_max->ts.kind != gfc_default_integer_kind
6495 && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
6496 "SYSTEM_CLOCK at %L has non-default kind",
6497 &count_max->where))
524af0d6 6498 return false;
21fdfcc1 6499
a416c4c7 6500 if (!variable_check (count_max, 2, false))
524af0d6 6501 return false;
27dfc9c4 6502 }
21fdfcc1 6503
524af0d6 6504 return true;
21fdfcc1 6505}
2bd74949 6506
65f8144a 6507
524af0d6 6508bool
65f8144a 6509gfc_check_irand (gfc_expr *x)
2bd74949 6510{
7a003d8e 6511 if (x == NULL)
524af0d6 6512 return true;
7a003d8e 6513
524af0d6
JB		 6514 if (!scalar_check (x, 0))
6515 return false;
2bd74949 6516
524af0d6
JB		 6517 if (!type_check (x, 0, BT_INTEGER))
6518 return false;
2bd74949 6519
524af0d6
JB		 6520 if (!kind_value_check (x, 0, 4))
6521 return false;
2bd74949 6522
524af0d6 6523 return true;
2bd74949
SK		 6524}
6525
185d7d97 6526
524af0d6 6527bool
65f8144a 6528gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
185d7d97 6529{
524af0d6
JB		 6530 if (!scalar_check (seconds, 0))
6531 return false;
6532 if (!type_check (seconds, 0, BT_INTEGER))
6533 return false;
185d7d97 6534
524af0d6
JB		 6535 if (!int_or_proc_check (handler, 1))
6536 return false;
6537 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
6538 return false;
185d7d97
FXC		 6539
6540 if (status == NULL)
524af0d6 6541 return true;
185d7d97 6542
524af0d6
JB		 6543 if (!scalar_check (status, 2))
6544 return false;
6545 if (!type_check (status, 2, BT_INTEGER))
6546 return false;
6547 if (!kind_value_check (status, 2, gfc_default_integer_kind))
6548 return false;
32af3784 6549
524af0d6 6550 return true;
185d7d97
FXC		 6551}
6552
6553
524af0d6 6554bool
65f8144a 6555gfc_check_rand (gfc_expr *x)
2bd74949 6556{
7a003d8e 6557 if (x == NULL)
524af0d6 6558 return true;
7a003d8e 6559
524af0d6
JB		 6560 if (!scalar_check (x, 0))
6561 return false;
2bd74949 6562
524af0d6
JB		 6563 if (!type_check (x, 0, BT_INTEGER))
6564 return false;
2bd74949 6565
524af0d6
JB		 6566 if (!kind_value_check (x, 0, 4))
6567 return false;
2bd74949 6568
524af0d6 6569 return true;
2bd74949
SK		 6570}
6571
65f8144a 6572
524af0d6 6573bool
65f8144a 6574gfc_check_srand (gfc_expr *x)
2bd74949 6575{
524af0d6
JB		 6576 if (!scalar_check (x, 0))
6577 return false;
2bd74949 6578
524af0d6
JB		 6579 if (!type_check (x, 0, BT_INTEGER))
6580 return false;
2bd74949 6581
524af0d6
JB		 6582 if (!kind_value_check (x, 0, 4))
6583 return false;
2bd74949 6584
524af0d6 6585 return true;
2bd74949
SK		 6586}
6587
65f8144a 6588
524af0d6 6589bool
65f8144a 6590gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
35059811 6591{
524af0d6
JB		 6592 if (!scalar_check (time, 0))
6593 return false;
6594 if (!type_check (time, 0, BT_INTEGER))
6595 return false;
35059811 6596
524af0d6
JB		 6597 if (!type_check (result, 1, BT_CHARACTER))
6598 return false;
6599 if (!kind_value_check (result, 1, gfc_default_character_kind))
6600 return false;
35059811 6601
524af0d6 6602 return true;
35059811
FXC		 6603}
6604
65f8144a 6605
524af0d6 6606bool
a1ba31ce 6607gfc_check_dtime_etime (gfc_expr *x)
2bd74949 6608{
524af0d6
JB		 6609 if (!array_check (x, 0))
6610 return false;
2bd74949 6611
524af0d6
JB		 6612 if (!rank_check (x, 0, 1))
6613 return false;
2bd74949 6614
524af0d6
JB		 6615 if (!variable_check (x, 0, false))
6616 return false;
2bd74949 6617
524af0d6
JB		 6618 if (!type_check (x, 0, BT_REAL))
6619 return false;
2bd74949 6620
524af0d6
JB		 6621 if (!kind_value_check (x, 0, 4))
6622 return false;
2bd74949 6623
524af0d6 6624 return true;
2bd74949
SK		 6625}
6626
65f8144a 6627
524af0d6 6628bool
a1ba31ce 6629gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
2bd74949 6630{
524af0d6
JB		 6631 if (!array_check (values, 0))
6632 return false;
2bd74949 6633
524af0d6
JB		 6634 if (!rank_check (values, 0, 1))
6635 return false;
2bd74949 6636
524af0d6
JB		 6637 if (!variable_check (values, 0, false))
6638 return false;
2bd74949 6639
524af0d6
JB		 6640 if (!type_check (values, 0, BT_REAL))
6641 return false;
2bd74949 6642
524af0d6
JB		 6643 if (!kind_value_check (values, 0, 4))
6644 return false;
2bd74949 6645
524af0d6
JB		 6646 if (!scalar_check (time, 1))
6647 return false;
2bd74949 6648
524af0d6
JB		 6649 if (!type_check (time, 1, BT_REAL))
6650 return false;
2bd74949 6651
524af0d6
JB		 6652 if (!kind_value_check (time, 1, 4))
6653 return false;
2bd74949 6654
524af0d6 6655 return true;
2bd74949 6656}
a8c60d7f
SK		 6657
6658
524af0d6 6659bool
65f8144a 6660gfc_check_fdate_sub (gfc_expr *date)
35059811 6661{
524af0d6
JB		 6662 if (!type_check (date, 0, BT_CHARACTER))
6663 return false;
6664 if (!kind_value_check (date, 0, gfc_default_character_kind))
6665 return false;
35059811 6666
524af0d6 6667 return true;
35059811
FXC		 6668}
6669
6670
524af0d6 6671bool
65f8144a 6672gfc_check_gerror (gfc_expr *msg)
f77b6ca3 6673{
524af0d6
JB		 6674 if (!type_check (msg, 0, BT_CHARACTER))
6675 return false;
6676 if (!kind_value_check (msg, 0, gfc_default_character_kind))
6677 return false;
f77b6ca3 6678
524af0d6 6679 return true;
f77b6ca3
FXC		 6680}
6681
6682
524af0d6 6683bool
65f8144a 6684gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
a8c60d7f 6685{
524af0d6
JB		 6686 if (!type_check (cwd, 0, BT_CHARACTER))
6687 return false;
6688 if (!kind_value_check (cwd, 0, gfc_default_character_kind))
6689 return false;
a8c60d7f 6690
d8fe26b2 6691 if (status == NULL)
524af0d6 6692 return true;
d8fe26b2 6693
524af0d6
JB		 6694 if (!scalar_check (status, 1))
6695 return false;
d8fe26b2 6696
524af0d6
JB		 6697 if (!type_check (status, 1, BT_INTEGER))
6698 return false;
d8fe26b2 6699
524af0d6 6700 return true;
d8fe26b2
SK		 6701}
6702
6703
524af0d6 6704bool
ed8315d5
FXC		 6705gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
6706{
524af0d6
JB		 6707 if (!type_check (pos, 0, BT_INTEGER))
6708 return false;
ed8315d5
FXC		 6709
6710 if (pos->ts.kind > gfc_default_integer_kind)
6711 {
c4100eae 6712 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
ed8315d5 6713 "not wider than the default kind (%d)",
c4aa95f8 6714 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
ed8315d5 6715 &pos->where, gfc_default_integer_kind);
524af0d6 6716 return false;
ed8315d5
FXC		 6717 }
6718
524af0d6
JB		 6719 if (!type_check (value, 1, BT_CHARACTER))
6720 return false;
6721 if (!kind_value_check (value, 1, gfc_default_character_kind))
6722 return false;
ed8315d5 6723
524af0d6 6724 return true;
ed8315d5
FXC		 6725}
6726
6727
524af0d6 6728bool
65f8144a 6729gfc_check_getlog (gfc_expr *msg)
f77b6ca3 6730{
524af0d6
JB		 6731 if (!type_check (msg, 0, BT_CHARACTER))
6732 return false;
6733 if (!kind_value_check (msg, 0, gfc_default_character_kind))
6734 return false;
f77b6ca3 6735
524af0d6 6736 return true;
f77b6ca3
FXC		 6737}
6738
6739
524af0d6 6740bool
65f8144a 6741gfc_check_exit (gfc_expr *status)
d8fe26b2 6742{
d8fe26b2 6743 if (status == NULL)
524af0d6 6744 return true;
d8fe26b2 6745
524af0d6
JB		 6746 if (!type_check (status, 0, BT_INTEGER))
6747 return false;
d8fe26b2 6748
524af0d6
JB		 6749 if (!scalar_check (status, 0))
6750 return false;
d8fe26b2 6751
524af0d6 6752 return true;
d8fe26b2
SK		 6753}
6754
6755
524af0d6 6756bool
65f8144a 6757gfc_check_flush (gfc_expr *unit)
df65f093 6758{
df65f093 6759 if (unit == NULL)
524af0d6 6760 return true;
df65f093 6761
524af0d6
JB		 6762 if (!type_check (unit, 0, BT_INTEGER))
6763 return false;
df65f093 6764
524af0d6
JB		 6765 if (!scalar_check (unit, 0))
6766 return false;
df65f093 6767
524af0d6 6768 return true;
df65f093
SK		 6769}
6770
6771
524af0d6 6772bool
65f8144a 6773gfc_check_free (gfc_expr *i)
0d519038 6774{
524af0d6
JB		 6775 if (!type_check (i, 0, BT_INTEGER))
6776 return false;
0d519038 6777
524af0d6
JB		 6778 if (!scalar_check (i, 0))
6779 return false;
0d519038 6780
524af0d6 6781 return true;
0d519038
FXC		 6782}
6783
6784
524af0d6 6785bool
65f8144a 6786gfc_check_hostnm (gfc_expr *name)
f77b6ca3 6787{
524af0d6
JB		 6788 if (!type_check (name, 0, BT_CHARACTER))
6789 return false;
6790 if (!kind_value_check (name, 0, gfc_default_character_kind))
6791 return false;
f77b6ca3 6792
524af0d6 6793 return true;
f77b6ca3
FXC		 6794}
6795
6796
524af0d6 6797bool
65f8144a 6798gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
f77b6ca3 6799{
524af0d6
JB		 6800 if (!type_check (name, 0, BT_CHARACTER))
6801 return false;
6802 if (!kind_value_check (name, 0, gfc_default_character_kind))
6803 return false;
f77b6ca3
FXC		 6804
6805 if (status == NULL)
524af0d6 6806 return true;
f77b6ca3 6807
524af0d6
JB		 6808 if (!scalar_check (status, 1))
6809 return false;
f77b6ca3 6810
524af0d6
JB		 6811 if (!type_check (status, 1, BT_INTEGER))
6812 return false;
f77b6ca3 6813
524af0d6 6814 return true;
f77b6ca3
FXC		 6815}
6816
6817
524af0d6 6818bool
65f8144a 6819gfc_check_itime_idate (gfc_expr *values)
12197210 6820{
524af0d6
JB		 6821 if (!array_check (values, 0))
6822 return false;
12197210 6823
524af0d6
JB		 6824 if (!rank_check (values, 0, 1))
6825 return false;
12197210 6826
524af0d6
JB		 6827 if (!variable_check (values, 0, false))
6828 return false;
12197210 6829
524af0d6
JB		 6830 if (!type_check (values, 0, BT_INTEGER))
6831 return false;
12197210 6832
524af0d6
JB		 6833 if (!kind_value_check (values, 0, gfc_default_integer_kind))
6834 return false;
12197210 6835
524af0d6 6836 return true;
12197210
FXC		 6837}
6838
6839
524af0d6 6840bool
65f8144a 6841gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
a119fc1c 6842{
524af0d6
JB		 6843 if (!type_check (time, 0, BT_INTEGER))
6844 return false;
a119fc1c 6845
524af0d6
JB		 6846 if (!kind_value_check (time, 0, gfc_default_integer_kind))
6847 return false;
a119fc1c 6848
524af0d6
JB		 6849 if (!scalar_check (time, 0))
6850 return false;
a119fc1c 6851
524af0d6
JB		 6852 if (!array_check (values, 1))
6853 return false;
a119fc1c 6854
524af0d6
JB		 6855 if (!rank_check (values, 1, 1))
6856 return false;
a119fc1c 6857
524af0d6
JB		 6858 if (!variable_check (values, 1, false))
6859 return false;
a119fc1c 6860
524af0d6
JB		 6861 if (!type_check (values, 1, BT_INTEGER))
6862 return false;
a119fc1c 6863
524af0d6
JB		 6864 if (!kind_value_check (values, 1, gfc_default_integer_kind))
6865 return false;
a119fc1c 6866
524af0d6 6867 return true;
a119fc1c
FXC		 6868}
6869
6870
524af0d6 6871bool
65f8144a 6872gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
ae8b8789 6873{
524af0d6
JB		 6874 if (!scalar_check (unit, 0))
6875 return false;
ae8b8789 6876
524af0d6
JB		 6877 if (!type_check (unit, 0, BT_INTEGER))
6878 return false;
ae8b8789 6879
524af0d6
JB		 6880 if (!type_check (name, 1, BT_CHARACTER))
6881 return false;
6882 if (!kind_value_check (name, 1, gfc_default_character_kind))
6883 return false;
ae8b8789 6884
524af0d6 6885 return true;
ae8b8789
FXC		 6886}
6887
6888
419af57c
TK		 6889bool
6890gfc_check_is_contiguous (gfc_expr *array)
6891{
6892 if (!array_check (array, 0))
6893 return false;
6894
6895 return true;
6896}
6897
6898
6899
524af0d6 6900bool
65f8144a 6901gfc_check_isatty (gfc_expr *unit)
ae8b8789
FXC		 6902{
6903 if (unit == NULL)
524af0d6 6904 return false;
ae8b8789 6905
524af0d6
JB		 6906 if (!type_check (unit, 0, BT_INTEGER))
6907 return false;
ae8b8789 6908
524af0d6
JB		 6909 if (!scalar_check (unit, 0))
6910 return false;
ae8b8789 6911
524af0d6 6912 return true;
ae8b8789
FXC		 6913}
6914
6915
524af0d6 6916bool
3d97b1af
FXC		 6917gfc_check_isnan (gfc_expr *x)
6918{
524af0d6
JB		 6919 if (!type_check (x, 0, BT_REAL))
6920 return false;
3d97b1af 6921
524af0d6 6922 return true;
3d97b1af
FXC		 6923}
6924
6925
524af0d6 6926bool
65f8144a 6927gfc_check_perror (gfc_expr *string)
f77b6ca3 6928{
524af0d6
JB		 6929 if (!type_check (string, 0, BT_CHARACTER))
6930 return false;
6931 if (!kind_value_check (string, 0, gfc_default_character_kind))
6932 return false;
f77b6ca3 6933
524af0d6 6934 return true;
f77b6ca3
FXC		 6935}
6936
6937
524af0d6 6938bool
65f8144a 6939gfc_check_umask (gfc_expr *mask)
d8fe26b2 6940{
524af0d6
JB		 6941 if (!type_check (mask, 0, BT_INTEGER))
6942 return false;
d8fe26b2 6943
524af0d6
JB		 6944 if (!scalar_check (mask, 0))
6945 return false;
d8fe26b2 6946
524af0d6 6947 return true;
d8fe26b2
SK		 6948}
6949
6950
524af0d6 6951bool
65f8144a 6952gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
d8fe26b2 6953{
524af0d6
JB		 6954 if (!type_check (mask, 0, BT_INTEGER))
6955 return false;
d8fe26b2 6956
524af0d6
JB		 6957 if (!scalar_check (mask, 0))
6958 return false;
d8fe26b2
SK		 6959
6960 if (old == NULL)
524af0d6 6961 return true;
d8fe26b2 6962
524af0d6
JB		 6963 if (!scalar_check (old, 1))
6964 return false;
d8fe26b2 6965
524af0d6
JB		 6966 if (!type_check (old, 1, BT_INTEGER))
6967 return false;
d8fe26b2 6968
524af0d6 6969 return true;
d8fe26b2
SK		 6970}
6971
6972
524af0d6 6973bool
65f8144a 6974gfc_check_unlink (gfc_expr *name)
d8fe26b2 6975{
524af0d6
JB		 6976 if (!type_check (name, 0, BT_CHARACTER))
6977 return false;
6978 if (!kind_value_check (name, 0, gfc_default_character_kind))
6979 return false;
d8fe26b2 6980
524af0d6 6981 return true;
d8fe26b2
SK		 6982}
6983
6984
524af0d6 6985bool
65f8144a 6986gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
d8fe26b2 6987{
524af0d6
JB		 6988 if (!type_check (name, 0, BT_CHARACTER))
6989 return false;
6990 if (!kind_value_check (name, 0, gfc_default_character_kind))
6991 return false;
d8fe26b2
SK		 6992
6993 if (status == NULL)
524af0d6 6994 return true;
d8fe26b2 6995
524af0d6
JB		 6996 if (!scalar_check (status, 1))
6997 return false;
a8c60d7f 6998
524af0d6
JB		 6999 if (!type_check (status, 1, BT_INTEGER))
7000 return false;
a8c60d7f 7001
524af0d6 7002 return true;
a8c60d7f 7003}
5b1374e9
TS		 7004
7005
524af0d6 7006bool
65f8144a 7007gfc_check_signal (gfc_expr *number, gfc_expr *handler)
185d7d97 7008{
524af0d6
JB		 7009 if (!scalar_check (number, 0))
7010 return false;
7011 if (!type_check (number, 0, BT_INTEGER))
7012 return false;
185d7d97 7013
524af0d6
JB		 7014 if (!int_or_proc_check (handler, 1))
7015 return false;
7016 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
7017 return false;
185d7d97 7018
524af0d6 7019 return true;
185d7d97
FXC		 7020}
7021
7022
524af0d6 7023bool
65f8144a 7024gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
185d7d97 7025{
524af0d6
JB		 7026 if (!scalar_check (number, 0))
7027 return false;
7028 if (!type_check (number, 0, BT_INTEGER))
7029 return false;
185d7d97 7030
524af0d6
JB		 7031 if (!int_or_proc_check (handler, 1))
7032 return false;
7033 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
7034 return false;
185d7d97
FXC		 7035
7036 if (status == NULL)
524af0d6 7037 return true;
185d7d97 7038
524af0d6
JB		 7039 if (!type_check (status, 2, BT_INTEGER))
7040 return false;
7041 if (!scalar_check (status, 2))
7042 return false;
185d7d97 7043
524af0d6 7044 return true;
185d7d97
FXC		 7045}
7046
7047
524af0d6 7048bool
65f8144a 7049gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
5b1374e9 7050{
524af0d6
JB		 7051 if (!type_check (cmd, 0, BT_CHARACTER))
7052 return false;
7053 if (!kind_value_check (cmd, 0, gfc_default_character_kind))
7054 return false;
5b1374e9 7055
524af0d6
JB		 7056 if (!scalar_check (status, 1))
7057 return false;
5b1374e9 7058
524af0d6
JB		 7059 if (!type_check (status, 1, BT_INTEGER))
7060 return false;
5b1374e9 7061
524af0d6
JB		 7062 if (!kind_value_check (status, 1, gfc_default_integer_kind))
7063 return false;
5b1374e9 7064
524af0d6 7065 return true;
5b1374e9 7066}
5d723e54
FXC		 7067
7068
7069/* This is used for the GNU intrinsics AND, OR and XOR. */
524af0d6 7070bool
65f8144a 7071gfc_check_and (gfc_expr *i, gfc_expr *j)
5d723e54 7072{
8dc63166
SK		 7073 /* i and j cannot both be BOZ literal constants. */
7074 if (!boz_args_check (i, j))
7075 return false;
5d723e54 7076
8dc63166
SK		 7077 /* If i is BOZ and j is integer, convert i to type of j. */
7078 if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
7079 && !gfc_boz2int (i, j->ts.kind))
7080 return false;
5d723e54 7081
8dc63166
SK		 7082 /* If j is BOZ and i is integer, convert j to type of i. */
7083 if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
7084 && !gfc_boz2int (j, i->ts.kind))
524af0d6 7085 return false;
5d723e54 7086
8dc63166 7087 if (!same_type_check (i, 0, j, 1, false))
524af0d6 7088 return false;
5d723e54 7089
8dc63166 7090 if (!scalar_check (i, 0))
89c1cf26
SK		 7091 return false;
7092
8dc63166
SK		 7093 if (!scalar_check (j, 1))
7094 return false;
89c1cf26 7095
524af0d6 7096 return true;
5d723e54 7097}
048510c8
JW		 7098
7099
524af0d6 7100bool
1a8c1e35 7101gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
048510c8 7102{
ce7fb711
SK		 7103
7104 if (a->expr_type == EXPR_NULL)
7105 {
7106 gfc_error ("Intrinsic function NULL at %L cannot be an actual "
7107 "argument to STORAGE_SIZE, because it returns a "
7108 "disassociated pointer", &a->where);
7109 return false;
7110 }
7111
1a8c1e35
TB		 7112 if (a->ts.type == BT_ASSUMED)
7113 {
c4100eae 7114 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
1a8c1e35
TB		 7115 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
7116 &a->where);
524af0d6 7117 return false;
1a8c1e35
TB		 7118 }
7119
7120 if (a->ts.type == BT_PROCEDURE)
7121 {
c4100eae 7122 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
1a8c1e35
TB		 7123 "procedure", gfc_current_intrinsic_arg[0]->name,
7124 gfc_current_intrinsic, &a->where);
524af0d6 7125 return false;
1a8c1e35
TB		 7126 }
7127
048510c8 7128 if (kind == NULL)
524af0d6 7129 return true;
048510c8 7130
524af0d6
JB		 7131 if (!type_check (kind, 1, BT_INTEGER))
7132 return false;
048510c8 7133
524af0d6
JB		 7134 if (!scalar_check (kind, 1))
7135 return false;
048510c8
JW		 7136
7137 if (kind->expr_type != EXPR_CONSTANT)
7138 {
c4100eae 7139 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
c4aa95f8 7140 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
048510c8 7141 &kind->where);
524af0d6 7142 return false;
048510c8
JW		 7143 }
7144
524af0d6 7145 return true;
048510c8 7146}
Mirror of https://gcc.gnu.org/git/gcc.git