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