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