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