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 64444 : scalar_check (gfc_expr *e, int n)
500 : {
501 64444 : 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 193158 : type_check (gfc_expr *e, int n, bt type)
516 : {
517 193158 : if (e->ts.type == type)
518 : return true;
519 :
520 3465 : gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
521 3465 : gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
522 : &e->where, gfc_basic_typename (type));
523 :
524 3465 : 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 18741 : 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 18741 : if (e->symtree && e->symtree->n.sym->attr.subroutine)
550 1 : goto error;
551 :
552 18740 : 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 3037 : real_or_complex_check (gfc_expr *e, int n)
693 : {
694 3037 : 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 87563 : kind_check (gfc_expr *k, int n, bt type)
728 : {
729 87563 : int kind;
730 :
731 87563 : 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 15476 : double_check (gfc_expr *d, int n)
764 : {
765 15476 : if (!type_check (d, n, BT_REAL))
766 : return false;
767 :
768 12111 : if (d->ts.kind != gfc_default_double_kind)
769 : {
770 7120 : gfc_error ("%qs argument of %qs intrinsic at %L must be double "
771 7120 : "precision", gfc_current_intrinsic_arg[n]->name,
772 : gfc_current_intrinsic, &d->where);
773 7120 : 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 40607 : logical_array_check (gfc_expr *array, int n)
807 : {
808 40607 : 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 62989 : array_check (gfc_expr *e, int n)
824 : {
825 62989 : if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
826 1133 : && CLASS_DATA (e)->attr.dimension
827 64122 : && CLASS_DATA (e)->as->rank)
828 : {
829 1133 : gfc_add_class_array_ref (e);
830 : }
831 :
832 62989 : 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 10128 : same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
1014 : {
1015 10128 : gfc_typespec *ets = &e->ts;
1016 10128 : gfc_typespec *fts = &f->ts;
1017 :
1018 10128 : 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 2329 : if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
1025 92 : ets = &e->symtree->n.sym->ts;
1026 2329 : if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
1027 91 : fts = &f->symtree->n.sym->ts;
1028 : }
1029 :
1030 10128 : 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 14824 : rank_check (gfc_expr *e, int n, int rank)
1046 : {
1047 14824 : 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 7775 : allocatable_check (gfc_expr *e, int n)
1080 : {
1081 7775 : symbol_attribute attr;
1082 :
1083 7775 : attr = gfc_variable_attr (e, NULL);
1084 7775 : if (!attr.allocatable
1085 7765 : || (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 20209 : variable_check (gfc_expr *e, int n, bool allow_proc)
1147 : {
1148 20209 : if (e->expr_type == EXPR_VARIABLE
1149 20183 : && 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 20236 : && !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 20203 : if (e->expr_type == EXPR_VARIABLE
1161 20177 : && e->symtree->n.sym->attr.flavor != FL_PARAMETER
1162 20177 : && (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 93011 : dim_check (gfc_expr *dim, int n, bool optional)
1192 : {
1193 93011 : if (dim == NULL)
1194 : return true;
1195 :
1196 31138 : if (!type_check (dim, n, BT_INTEGER))
1197 : return false;
1198 :
1199 31122 : if (!scalar_check (dim, n))
1200 : return false;
1201 :
1202 31118 : 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 91450 : dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
1243 : {
1244 91450 : gfc_array_ref *ar;
1245 91450 : int rank;
1246 :
1247 91450 : if (dim == NULL)
1248 : return true;
1249 :
1250 29577 : if (dim->expr_type != EXPR_CONSTANT)
1251 : return true;
1252 :
1253 28136 : 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 28076 : rank = array->rank;
1258 :
1259 : /* Assumed-rank array. */
1260 28136 : if (rank == -1)
1261 1164 : rank = GFC_MAX_DIMENSIONS;
1262 :
1263 28136 : if (array->expr_type == EXPR_VARIABLE)
1264 : {
1265 26925 : ar = gfc_find_array_ref (array, true);
1266 26925 : if (!ar)
1267 : return false;
1268 26924 : 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 28135 : if (mpz_cmp_ui (dim->value.integer, 1) < 0
1276 28133 : || 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 4604 : gfc_check_abs (gfc_expr *a)
1452 : {
1453 4604 : 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 40258 : gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
1504 : {
1505 40258 : if (!logical_array_check (mask, 0))
1506 : return false;
1507 :
1508 40258 : if (!dim_check (dim, 1, false))
1509 : return false;
1510 :
1511 40258 : 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 7178 : 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 7178 : 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 7178 : if (!variable_check (array, 0, false))
1537 : return false;
1538 7177 : 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 44431 : gfc_invalid_null_arg (gfc_expr *x)
1617 : {
1618 44431 : 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 7091 : gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
1630 : {
1631 7091 : symbol_attribute attr1, attr2;
1632 7091 : int i;
1633 7091 : bool t;
1634 :
1635 7091 : if (gfc_invalid_null_arg (pointer))
1636 : return false;
1637 :
1638 7090 : attr1 = gfc_expr_attr (pointer);
1639 :
1640 7090 : 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 7089 : 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 7088 : if (target == NULL)
1659 : return true;
1660 :
1661 2332 : if (gfc_invalid_null_arg (target))
1662 : return false;
1663 :
1664 2331 : if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
1665 2330 : 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 2330 : 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 2330 : 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 2329 : t = true;
1693 2329 : 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 2329 : if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank))
1698 : t = false;
1699 2329 : 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 1073 : gfc_check_char (gfc_expr *i, gfc_expr *kind)
2245 : {
2246 1073 : 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 1073 : if (!type_check (i, 0, BT_INTEGER))
2257 : return false;
2258 :
2259 1073 : 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 12780 : gfc_check_fn_d (gfc_expr *a)
3322 : {
3323 12780 : 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 1000 : gfc_check_fn_rc (gfc_expr *a)
3333 : {
3334 1000 : 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 8977 : gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
3518 : {
3519 8977 : int i;
3520 :
3521 8977 : if (!type_check (c, 0, BT_CHARACTER))
3522 : return false;
3523 :
3524 8977 : if (!kind_check (kind, 1, BT_INTEGER))
3525 : return false;
3526 :
3527 8977 : 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 8977 : if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
3533 : {
3534 1957 : gfc_expr *start;
3535 1957 : gfc_expr *end;
3536 1957 : gfc_ref *ref;
3537 :
3538 : /* Substring references don't have the charlength set. */
3539 1957 : ref = c->ref;
3540 2102 : while (ref && ref->type != REF_SUBSTRING)
3541 145 : ref = ref->next;
3542 :
3543 1957 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3544 :
3545 1957 : 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 266 : start = ref->u.ss.start;
3562 266 : end = ref->u.ss.end;
3563 :
3564 266 : gcc_assert (start);
3565 266 : 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 5068 : gfc_check_kind (gfc_expr *x)
3835 : {
3836 5068 : if (gfc_invalid_null_arg (x))
3837 : return false;
3838 :
3839 5067 : 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 5065 : 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 10816 : gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
3912 : {
3913 10816 : 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)
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 : i++;
4102 26 : if (n == 1)
4103 : a1 = true;
4104 15 : if (n == 2)
4105 5 : a2 = true;
4106 : }
4107 : else
4108 1 : nlabelless++;
4109 :
4110 6 : if (!a1 || !a2)
4111 : {
4112 4 : gfc_error ("Missing %qs argument to the %s intrinsic at %L",
4113 : !a1 ? "a1" : "a2", gfc_current_intrinsic,
4114 : gfc_current_intrinsic_where);
4115 4 : return false;
4116 : }
4117 :
4118 : /* Check for duplicates. */
4119 8 : for (i = 0; i < nargs; i++)
4120 12 : for (j = i + 1; j < nargs; j++)
4121 6 : if (nlabels[i] == nlabels[j])
4122 0 : goto duplicate;
4123 :
4124 : return true;
4125 :
4126 1 : duplicate:
4127 1 : gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
4128 1 : &arg->expr->where, gfc_current_intrinsic);
4129 1 : return false;
4130 :
4131 6 : unknown:
4132 6 : gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
4133 6 : &arg->expr->where, gfc_current_intrinsic);
4134 6 : return false;
4135 : }
4136 :
4137 :
4138 : static bool
4139 2539 : check_rest (bt type, int kind, gfc_actual_arglist *arglist)
4140 : {
4141 2539 : gfc_actual_arglist *arg, *tmp;
4142 2539 : gfc_expr *x;
4143 2539 : int m, n;
4144 :
4145 2539 : if (!min_max_args (arglist))
4146 : return false;
4147 :
4148 8288 : for (arg = arglist, n=1; arg; arg = arg->next, n++)
4149 : {
4150 5796 : x = arg->expr;
4151 5796 : if (x->ts.type != type || x->ts.kind != kind)
4152 : {
4153 138 : if (x->ts.type == type)
4154 : {
4155 138 : if (x->ts.type == BT_CHARACTER)
4156 : {
4157 2 : gfc_error ("Different character kinds at %L", &x->where);
4158 2 : return false;
4159 : }
4160 136 : if (!gfc_notify_std (GFC_STD_GNU, "Different type "
4161 : "kinds at %L", &x->where))
4162 : return false;
4163 : }
4164 : else
4165 : {
4166 0 : gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
4167 : "%s(%d)", n, gfc_current_intrinsic, &x->where,
4168 : gfc_basic_typename (type), kind);
4169 0 : return false;
4170 : }
4171 : }
4172 :
4173 10040 : for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
4174 4282 : if (!gfc_check_conformance (tmp->expr, x,
4175 4282 : _("arguments 'a%d' and 'a%d' for "
4176 : "intrinsic '%s'"), m, n,
4177 : gfc_current_intrinsic))
4178 : return false;
4179 : }
4180 :
4181 : return true;
4182 : }
4183 :
4184 :
4185 : bool
4186 2451 : gfc_check_min_max (gfc_actual_arglist *arg)
4187 : {
4188 2451 : gfc_expr *x;
4189 :
4190 2451 : if (!min_max_args (arg))
4191 : return false;
4192 :
4193 2449 : x = arg->expr;
4194 :
4195 2449 : if (x->ts.type == BT_CHARACTER)
4196 : {
4197 521 : if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
4198 : "with CHARACTER argument at %L",
4199 : gfc_current_intrinsic, &x->where))
4200 : return false;
4201 : }
4202 : else
4203 : {
4204 1928 : if (flag_unsigned)
4205 : {
4206 78 : if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL
4207 : && x->ts.type != BT_UNSIGNED)
4208 : {
4209 0 : gfc_error ("%<a1%> argument of %qs intrinsic at %L must be "
4210 : "INTEGER, REAL, CHARACTER or UNSIGNED",
4211 : gfc_current_intrinsic, &x->where);
4212 0 : return false;
4213 : }
4214 : }
4215 : else
4216 : {
4217 1850 : if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
4218 : {
4219 0 : gfc_error ("%<a1%> argument of %qs intrinsic at %L must be "
4220 : "INTEGER, REAL or CHARACTER",
4221 : gfc_current_intrinsic, &x->where);
4222 0 : return false;
4223 : }
4224 : }
4225 : }
4226 :
4227 2448 : return check_rest (x->ts.type, x->ts.kind, arg);
4228 : }
4229 :
4230 :
4231 : bool
4232 43 : gfc_check_min_max_integer (gfc_actual_arglist *arg)
4233 : {
4234 43 : return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
4235 : }
4236 :
4237 :
4238 : bool
4239 38 : gfc_check_min_max_real (gfc_actual_arglist *arg)
4240 : {
4241 38 : return check_rest (BT_REAL, gfc_default_real_kind, arg);
4242 : }
4243 :
4244 :
4245 : bool
4246 10 : gfc_check_min_max_double (gfc_actual_arglist *arg)
4247 : {
4248 10 : return check_rest (BT_REAL, gfc_default_double_kind, arg);
4249 : }
4250 :
4251 :
4252 : /* End of min/max family. */
4253 :
4254 : bool
4255 16 : gfc_check_malloc (gfc_expr *size)
4256 : {
4257 16 : if (!type_check (size, 0, BT_INTEGER))
4258 : return false;
4259 :
4260 16 : if (!scalar_check (size, 0))
4261 : return false;
4262 :
4263 : return true;
4264 : }
4265 :
4266 :
4267 : bool
4268 948 : gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4269 : {
4270 948 : if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
4271 : {
4272 3 : gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
4273 3 : "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
4274 : gfc_current_intrinsic, &matrix_a->where);
4275 3 : return false;
4276 : }
4277 :
4278 945 : if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
4279 : {
4280 2 : gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
4281 2 : "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
4282 : gfc_current_intrinsic, &matrix_b->where);
4283 2 : return false;
4284 : }
4285 :
4286 20 : if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
4287 942 : || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)
4288 1884 : || gfc_invalid_unsigned_ops (matrix_a, matrix_b))
4289 : {
4290 2 : gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
4291 : gfc_current_intrinsic, &matrix_a->where,
4292 : gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
4293 2 : return false;
4294 : }
4295 :
4296 941 : switch (matrix_a->rank)
4297 : {
4298 145 : case 1:
4299 145 : if (!rank_check (matrix_b, 1, 2))
4300 : return false;
4301 : /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
4302 145 : if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
4303 : {
4304 2 : gfc_error ("Different shape on dimension 1 for arguments %qs "
4305 : "and %qs at %L for intrinsic matmul",
4306 2 : gfc_current_intrinsic_arg[0]->name,
4307 2 : gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
4308 2 : return false;
4309 : }
4310 : break;
4311 :
4312 796 : case 2:
4313 796 : if (matrix_b->rank != 2)
4314 : {
4315 157 : if (!rank_check (matrix_b, 1, 1))
4316 : return false;
4317 : }
4318 : /* matrix_b has rank 1 or 2 here. Common check for the cases
4319 : - matrix_a has shape (n,m) and matrix_b has shape (m, k)
4320 : - matrix_a has shape (n,m) and matrix_b has shape (m). */
4321 796 : if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
4322 : {
4323 0 : gfc_error ("Different shape on dimension 2 for argument %qs and "
4324 : "dimension 1 for argument %qs at %L for intrinsic "
4325 0 : "matmul", gfc_current_intrinsic_arg[0]->name,
4326 0 : gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
4327 0 : return false;
4328 : }
4329 : break;
4330 :
4331 0 : default:
4332 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
4333 0 : "1 or 2", gfc_current_intrinsic_arg[0]->name,
4334 : gfc_current_intrinsic, &matrix_a->where);
4335 0 : return false;
4336 : }
4337 :
4338 : return true;
4339 : }
4340 :
4341 :
4342 : /* Whoever came up with this interface was probably on something.
4343 : The possibilities for the occupation of the second and third
4344 : parameters are:
4345 :
4346 : Arg #2 Arg #3
4347 : NULL NULL
4348 : DIM NULL
4349 : MASK NULL
4350 : NULL MASK minloc(array, mask=m)
4351 : DIM MASK
4352 :
4353 : I.e. in the case of minloc(array,mask), mask will be in the second
4354 : position of the argument list and we'll have to fix that up. Also,
4355 : add the BACK argument if that isn't present. */
4356 :
4357 : bool
4358 14339 : gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
4359 : {
4360 14339 : gfc_expr *a, *m, *d, *k, *b;
4361 :
4362 14339 : a = ap->expr;
4363 :
4364 14339 : if (flag_unsigned)
4365 : {
4366 126 : if (!int_or_real_or_char_or_unsigned_check_f2003 (a, 0))
4367 : return false;
4368 : }
4369 : else
4370 14213 : if (!int_or_real_or_char_check_f2003 (a, 0))
4371 : return false;
4372 :
4373 14339 : if (!array_check (a, 0))
4374 : return false;
4375 :
4376 14339 : d = ap->next->expr;
4377 14339 : m = ap->next->next->expr;
4378 14339 : k = ap->next->next->next->expr;
4379 14339 : b = ap->next->next->next->next->expr;
4380 :
4381 14339 : if (b)
4382 : {
4383 3874 : if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4))
4384 4 : return false;
4385 : }
4386 : else
4387 : {
4388 10465 : b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
4389 10465 : ap->next->next->next->next->expr = b;
4390 10465 : ap->next->next->next->next->name = gfc_get_string ("back");
4391 : }
4392 :
4393 14335 : if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
4394 62 : && ap->next->name == NULL)
4395 : {
4396 62 : m = d;
4397 62 : d = NULL;
4398 62 : ap->next->expr = NULL;
4399 62 : ap->next->next->expr = m;
4400 : }
4401 :
4402 14335 : if (!dim_check (d, 1, false))
4403 : return false;
4404 :
4405 14335 : if (!dim_rank_check (d, a, 0))
4406 : return false;
4407 :
4408 14334 : if (m != NULL && !type_check (m, 2, BT_LOGICAL))
4409 : return false;
4410 :
4411 14330 : if (m != NULL
4412 23602 : && !gfc_check_conformance (a, m,
4413 9272 : _("arguments '%s' and '%s' for intrinsic %s"),
4414 9272 : gfc_current_intrinsic_arg[0]->name,
4415 9272 : gfc_current_intrinsic_arg[2]->name,
4416 : gfc_current_intrinsic))
4417 : return false;
4418 :
4419 14322 : if (!kind_check (k, 1, BT_INTEGER))
4420 : return false;
4421 :
4422 : return true;
4423 : }
4424 :
4425 : /* Check function for findloc. Mostly like gfc_check_minloc_maxloc
4426 : above, with the additional "value" argument. */
4427 :
4428 : bool
4429 901 : gfc_check_findloc (gfc_actual_arglist *ap)
4430 : {
4431 901 : gfc_expr *a, *v, *m, *d, *k, *b;
4432 901 : bool a1, v1;
4433 :
4434 901 : a = ap->expr;
4435 901 : if (!intrinsic_type_check (a, 0) || !array_check (a, 0))
4436 0 : return false;
4437 :
4438 901 : v = ap->next->expr;
4439 901 : if (!intrinsic_type_check (v, 1) || !scalar_check (v,1))
4440 1 : return false;
4441 :
4442 : /* Check if the type are both logical. */
4443 900 : a1 = a->ts.type == BT_LOGICAL;
4444 900 : v1 = v->ts.type == BT_LOGICAL;
4445 900 : if ((a1 && !v1) || (!a1 && v1))
4446 1 : goto incompat;
4447 :
4448 : /* Check if the type are both character. */
4449 899 : a1 = a->ts.type == BT_CHARACTER;
4450 899 : v1 = v->ts.type == BT_CHARACTER;
4451 899 : if ((a1 && !v1) || (!a1 && v1))
4452 2 : goto incompat;
4453 :
4454 897 : if (flag_unsigned && gfc_invalid_unsigned_ops (a,v))
4455 0 : goto incompat;
4456 :
4457 : /* Check the kind of the characters argument match. */
4458 897 : if (a1 && v1 && a->ts.kind != v->ts.kind)
4459 4 : goto incompat;
4460 :
4461 893 : d = ap->next->next->expr;
4462 893 : m = ap->next->next->next->expr;
4463 893 : k = ap->next->next->next->next->expr;
4464 893 : b = ap->next->next->next->next->next->expr;
4465 :
4466 893 : if (b)
4467 : {
4468 248 : if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4))
4469 0 : return false;
4470 : }
4471 : else
4472 : {
4473 645 : b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
4474 645 : ap->next->next->next->next->next->expr = b;
4475 645 : ap->next->next->next->next->next->name = gfc_get_string ("back");
4476 : }
4477 :
4478 893 : if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
4479 13 : && ap->next->name == NULL)
4480 : {
4481 13 : m = d;
4482 13 : d = NULL;
4483 13 : ap->next->next->expr = NULL;
4484 13 : ap->next->next->next->expr = m;
4485 : }
4486 :
4487 893 : if (!dim_check (d, 2, false))
4488 : return false;
4489 :
4490 892 : if (!dim_rank_check (d, a, 0))
4491 : return false;
4492 :
4493 891 : if (m != NULL && !type_check (m, 3, BT_LOGICAL))
4494 : return false;
4495 :
4496 889 : if (m != NULL
4497 1307 : && !gfc_check_conformance (a, m,
4498 418 : _("arguments '%s' and '%s' for intrinsic %s"),
4499 418 : gfc_current_intrinsic_arg[0]->name,
4500 418 : gfc_current_intrinsic_arg[3]->name,
4501 : gfc_current_intrinsic))
4502 : return false;
4503 :
4504 888 : if (!kind_check (k, 1, BT_INTEGER))
4505 : return false;
4506 :
4507 : return true;
4508 :
4509 7 : incompat:
4510 7 : gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
4511 : "conformance to argument %qs at %L",
4512 7 : gfc_current_intrinsic_arg[0]->name,
4513 : gfc_current_intrinsic, &a->where,
4514 7 : gfc_current_intrinsic_arg[1]->name, &v->where);
4515 7 : return false;
4516 : }
4517 :
4518 :
4519 : /* Similar to minloc/maxloc, the argument list might need to be
4520 : reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
4521 : difference is that MINLOC/MAXLOC take an additional KIND argument.
4522 : The possibilities are:
4523 :
4524 : Arg #2 Arg #3
4525 : NULL NULL
4526 : DIM NULL
4527 : MASK NULL
4528 : NULL MASK minval(array, mask=m)
4529 : DIM MASK
4530 :
4531 : I.e. in the case of minval(array,mask), mask will be in the second
4532 : position of the argument list and we'll have to fix that up. */
4533 :
4534 : static bool
4535 7463 : check_reduction (gfc_actual_arglist *ap)
4536 : {
4537 7463 : gfc_expr *a, *m, *d;
4538 :
4539 7463 : a = ap->expr;
4540 7463 : d = ap->next->expr;
4541 7463 : m = ap->next->next->expr;
4542 :
4543 7463 : if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
4544 290 : && ap->next->name == NULL)
4545 : {
4546 290 : m = d;
4547 290 : d = NULL;
4548 290 : ap->next->expr = NULL;
4549 290 : ap->next->next->expr = m;
4550 : }
4551 :
4552 7463 : if (!dim_check (d, 1, false))
4553 : return false;
4554 :
4555 7463 : if (!dim_rank_check (d, a, 0))
4556 : return false;
4557 :
4558 7460 : if (m != NULL && !type_check (m, 2, BT_LOGICAL))
4559 : return false;
4560 :
4561 7460 : if (m != NULL
4562 10855 : && !gfc_check_conformance (a, m,
4563 3395 : _("arguments '%s' and '%s' for intrinsic %s"),
4564 3395 : gfc_current_intrinsic_arg[0]->name,
4565 3395 : gfc_current_intrinsic_arg[2]->name,
4566 : gfc_current_intrinsic))
4567 : return false;
4568 :
4569 : return true;
4570 : }
4571 :
4572 :
4573 : bool
4574 4062 : gfc_check_minval_maxval (gfc_actual_arglist *ap)
4575 : {
4576 4062 : if (flag_unsigned)
4577 : {
4578 108 : if (!int_or_real_or_char_or_unsigned_check_f2003 (ap->expr, 0))
4579 : return false;
4580 : }
4581 3954 : else if (!int_or_real_or_char_check_f2003 (ap->expr, 0))
4582 : return false;
4583 :
4584 4062 : if (!array_check (ap->expr, 0))
4585 : return false;
4586 :
4587 4062 : return check_reduction (ap);
4588 : }
4589 :
4590 :
4591 : bool
4592 2870 : gfc_check_product_sum (gfc_actual_arglist *ap)
4593 : {
4594 2870 : if (!numeric_check (ap->expr, 0)
4595 2870 : || !array_check (ap->expr, 0))
4596 0 : return false;
4597 :
4598 2870 : return check_reduction (ap);
4599 : }
4600 :
4601 :
4602 : /* For IANY, IALL and IPARITY. */
4603 :
4604 : bool
4605 1020 : gfc_check_mask (gfc_expr *i, gfc_expr *kind)
4606 : {
4607 1020 : int k;
4608 :
4609 1020 : if (flag_unsigned)
4610 : {
4611 96 : if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
4612 : return false;
4613 : }
4614 924 : else if (!type_check (i, 0, BT_INTEGER))
4615 : return false;
4616 :
4617 1020 : if (!nonnegative_check ("I", i))
4618 : return false;
4619 :
4620 1018 : if (!kind_check (kind, 1, BT_INTEGER))
4621 : return false;
4622 :
4623 1018 : if (kind)
4624 960 : gfc_extract_int (kind, &k);
4625 : else
4626 58 : k = i->ts.type == BT_UNSIGNED ? gfc_default_unsigned_kind : gfc_default_integer_kind;
4627 :
4628 1018 : if (!less_than_bitsizekind ("I", i, k))
4629 : return false;
4630 :
4631 : return true;
4632 : }
4633 :
4634 :
4635 : bool
4636 531 : gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
4637 : {
4638 531 : bt type = ap->expr->ts.type;
4639 :
4640 531 : if (flag_unsigned)
4641 : {
4642 108 : if (type != BT_INTEGER && type != BT_UNSIGNED)
4643 : {
4644 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
4645 0 : "or UNSIGNED", gfc_current_intrinsic_arg[0]->name,
4646 : gfc_current_intrinsic, &ap->expr->where);
4647 0 : return false;
4648 : }
4649 : }
4650 423 : else if (ap->expr->ts.type != BT_INTEGER)
4651 : {
4652 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
4653 0 : gfc_current_intrinsic_arg[0]->name,
4654 : gfc_current_intrinsic, &ap->expr->where);
4655 0 : return false;
4656 : }
4657 :
4658 531 : if (!array_check (ap->expr, 0))
4659 : return false;
4660 :
4661 531 : return check_reduction (ap);
4662 : }
4663 :
4664 :
4665 : bool
4666 1470 : gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4667 : {
4668 1470 : if (gfc_invalid_null_arg (tsource))
4669 : return false;
4670 :
4671 1468 : if (gfc_invalid_null_arg (fsource))
4672 : return false;
4673 :
4674 1467 : if (!same_type_check (tsource, 0, fsource, 1))
4675 : return false;
4676 :
4677 1467 : if (!type_check (mask, 2, BT_LOGICAL))
4678 : return false;
4679 :
4680 1467 : if (tsource->ts.type == BT_CHARACTER)
4681 566 : return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
4682 :
4683 : return true;
4684 : }
4685 :
4686 :
4687 : bool
4688 337 : gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
4689 : {
4690 : /* i and j cannot both be BOZ literal constants. */
4691 337 : if (!boz_args_check (i, j))
4692 : return false;
4693 :
4694 : /* If i is BOZ and j is integer, convert i to type of j. */
4695 12 : if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER
4696 348 : && !gfc_boz2int (i, j->ts.kind))
4697 : return false;
4698 :
4699 : /* If j is BOZ and i is integer, convert j to type of i. */
4700 24 : if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER
4701 360 : && !gfc_boz2int (j, i->ts.kind))
4702 : return false;
4703 :
4704 336 : if (flag_unsigned)
4705 : {
4706 : /* If i is BOZ and j is unsigned, convert i to type of j. */
4707 0 : if (i->ts.type == BT_BOZ && j->ts.type == BT_UNSIGNED
4708 24 : && !gfc_boz2uint (i, j->ts.kind))
4709 : return false;
4710 :
4711 : /* If j is BOZ and i is unsigned, convert j to type of i. */
4712 0 : if (j->ts.type == BT_BOZ && i->ts.type == BT_UNSIGNED
4713 24 : && !gfc_boz2int (j, i->ts.kind))
4714 : return false;
4715 :
4716 24 : if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
4717 : return false;
4718 :
4719 24 : if (!type_check2 (j, 1, BT_INTEGER, BT_UNSIGNED))
4720 : return false;
4721 : }
4722 : else
4723 : {
4724 312 : if (!type_check (i, 0, BT_INTEGER))
4725 : return false;
4726 :
4727 312 : if (!type_check (j, 1, BT_INTEGER))
4728 : return false;
4729 : }
4730 :
4731 336 : if (!same_type_check (i, 0, j, 1))
4732 : return false;
4733 :
4734 336 : if (mask->ts.type == BT_BOZ)
4735 : {
4736 24 : if (i->ts.type == BT_INTEGER && !gfc_boz2int (mask, i->ts.kind))
4737 : return false;
4738 24 : if (i->ts.type == BT_UNSIGNED && !gfc_boz2uint (mask, i->ts.kind))
4739 : return false;
4740 : }
4741 :
4742 336 : if (flag_unsigned)
4743 : {
4744 24 : if (!type_check2 (mask, 2, BT_INTEGER, BT_UNSIGNED))
4745 : return false;
4746 : }
4747 : else
4748 : {
4749 312 : if (!type_check (mask, 2, BT_INTEGER))
4750 : return false;
4751 : }
4752 :
4753 336 : if (!same_type_check (i, 0, mask, 2))
4754 : return false;
4755 :
4756 : return true;
4757 : }
4758 :
4759 :
4760 : bool
4761 308 : gfc_check_move_alloc (gfc_expr *from, gfc_expr *to, gfc_expr *stat,
4762 : gfc_expr *errmsg)
4763 : {
4764 308 : struct sync_stat sync_stat = {stat, errmsg};
4765 :
4766 308 : if ((stat || errmsg)
4767 308 : && !gfc_notify_std (GFC_STD_F2008, "STAT= or ERRMSG= at %L not supported",
4768 : &to->where))
4769 : return false;
4770 :
4771 308 : gfc_resolve_sync_stat (&sync_stat);
4772 :
4773 308 : if (!variable_check (from, 0, false))
4774 : return false;
4775 303 : if (!allocatable_check (from, 0))
4776 : return false;
4777 297 : if (gfc_is_coindexed (from))
4778 : {
4779 2 : gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be "
4780 : "coindexed", &from->where);
4781 2 : return false;
4782 : }
4783 :
4784 295 : if (!variable_check (to, 1, false))
4785 : return false;
4786 295 : if (!allocatable_check (to, 1))
4787 : return false;
4788 294 : if (gfc_is_coindexed (to))
4789 : {
4790 2 : gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be "
4791 : "coindexed", &to->where);
4792 2 : return false;
4793 : }
4794 :
4795 292 : if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
4796 : {
4797 1 : gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
4798 : "polymorphic if FROM is polymorphic",
4799 : &to->where);
4800 1 : return false;
4801 : }
4802 :
4803 291 : if (!same_type_check (to, 1, from, 0))
4804 : return false;
4805 :
4806 291 : if (to->rank != from->rank)
4807 : {
4808 0 : gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4809 : "must have the same rank %d/%d", &to->where, from->rank,
4810 : to->rank);
4811 0 : return false;
4812 : }
4813 :
4814 : /* IR F08/0040; cf. 12-006A. */
4815 291 : if (to->corank != from->corank)
4816 : {
4817 4 : gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L "
4818 : "must have the same corank %d/%d",
4819 : &to->where, from->corank, to->corank);
4820 4 : return false;
4821 : }
4822 :
4823 : /* This is based losely on F2003 12.4.1.7. It is intended to prevent
4824 : the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1
4825 : and cmp2 are allocatable. After the allocation is transferred,
4826 : the 'to' chain is broken by the nullification of the 'from'. A bit
4827 : of reflection reveals that this can only occur for derived types
4828 : with recursive allocatable components. */
4829 287 : if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
4830 287 : && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
4831 : {
4832 2 : gfc_ref *to_ref, *from_ref;
4833 2 : to_ref = to->ref;
4834 2 : from_ref = from->ref;
4835 2 : bool aliasing = true;
4836 :
4837 3 : for (; from_ref && to_ref;
4838 1 : from_ref = from_ref->next, to_ref = to_ref->next)
4839 : {
4840 2 : if (to_ref->type != from->ref->type)
4841 : aliasing = false;
4842 2 : else if (to_ref->type == REF_ARRAY
4843 1 : && to_ref->u.ar.type != AR_FULL
4844 1 : && from_ref->u.ar.type != AR_FULL)
4845 : /* Play safe; assume sections and elements are different. */
4846 : aliasing = false;
4847 1 : else if (to_ref->type == REF_COMPONENT
4848 1 : && to_ref->u.c.component != from_ref->u.c.component)
4849 : aliasing = false;
4850 :
4851 1 : if (!aliasing)
4852 : break;
4853 : }
4854 :
4855 2 : if (aliasing)
4856 : {
4857 1 : gfc_error ("The FROM and TO arguments at %L violate aliasing "
4858 : "restrictions (F2003 12.4.1.7)", &to->where);
4859 1 : return false;
4860 : }
4861 : }
4862 :
4863 : /* CLASS arguments: Make sure the vtab of from is present. */
4864 286 : if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
4865 94 : gfc_find_vtab (&from->ts);
4866 :
4867 : return true;
4868 : }
4869 :
4870 :
4871 : bool
4872 2490 : gfc_check_nearest (gfc_expr *x, gfc_expr *s)
4873 : {
4874 2490 : if (!type_check (x, 0, BT_REAL))
4875 : return false;
4876 :
4877 2490 : if (!type_check (s, 1, BT_REAL))
4878 : return false;
4879 :
4880 2490 : if (s->expr_type == EXPR_CONSTANT)
4881 : {
4882 2394 : if (mpfr_sgn (s->value.real) == 0)
4883 : {
4884 4 : gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
4885 : &s->where);
4886 4 : return false;
4887 : }
4888 : }
4889 :
4890 : return true;
4891 : }
4892 :
4893 :
4894 : bool
4895 331 : gfc_check_new_line (gfc_expr *a)
4896 : {
4897 331 : if (!type_check (a, 0, BT_CHARACTER))
4898 : return false;
4899 :
4900 : return true;
4901 : }
4902 :
4903 :
4904 : bool
4905 172 : gfc_check_norm2 (gfc_expr *array, gfc_expr *dim)
4906 : {
4907 172 : if (!type_check (array, 0, BT_REAL))
4908 : return false;
4909 :
4910 170 : if (!array_check (array, 0))
4911 : return false;
4912 :
4913 169 : if (!dim_check (dim, 1, false))
4914 : return false;
4915 :
4916 168 : if (!dim_rank_check (dim, array, false))
4917 : return false;
4918 :
4919 : return true;
4920 : }
4921 :
4922 : bool
4923 1967 : gfc_check_null (gfc_expr *mold)
4924 : {
4925 1967 : symbol_attribute attr;
4926 :
4927 1967 : if (mold == NULL)
4928 : return true;
4929 :
4930 566 : if (mold->expr_type == EXPR_NULL)
4931 : return true;
4932 :
4933 563 : if (!variable_check (mold, 0, true))
4934 : return false;
4935 :
4936 563 : attr = gfc_variable_attr (mold, NULL);
4937 :
4938 563 : if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
4939 : {
4940 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
4941 : "ALLOCATABLE or procedure pointer",
4942 0 : gfc_current_intrinsic_arg[0]->name,
4943 : gfc_current_intrinsic, &mold->where);
4944 0 : return false;
4945 : }
4946 :
4947 563 : if (attr.allocatable
4948 563 : && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with "
4949 : "allocatable MOLD at %L", &mold->where))
4950 : return false;
4951 :
4952 : /* F2008, C1242. */
4953 562 : if (gfc_is_coindexed (mold))
4954 : {
4955 1 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
4956 1 : "coindexed", gfc_current_intrinsic_arg[0]->name,
4957 : gfc_current_intrinsic, &mold->where);
4958 1 : return false;
4959 : }
4960 :
4961 : return true;
4962 : }
4963 :
4964 :
4965 : bool
4966 648 : gfc_check_out_of_range (gfc_expr *x, gfc_expr *mold, gfc_expr *round)
4967 : {
4968 648 : if (!int_or_real_or_unsigned_check (x, 0))
4969 : return false;
4970 :
4971 648 : if (mold == NULL)
4972 : return false;
4973 :
4974 648 : if (!int_or_real_or_unsigned_check (mold, 1))
4975 : return false;
4976 :
4977 648 : if (!scalar_check (mold, 1))
4978 : return false;
4979 :
4980 648 : if (round)
4981 : {
4982 282 : if (!type_check (round, 2, BT_LOGICAL))
4983 : return false;
4984 :
4985 282 : if (!scalar_check (round, 2))
4986 : return false;
4987 :
4988 282 : if (x->ts.type != BT_REAL
4989 282 : || (mold->ts.type != BT_INTEGER && mold->ts.type != BT_UNSIGNED))
4990 : {
4991 0 : gfc_error ("%qs argument of %qs intrinsic at %L shall appear "
4992 : "only if %qs is of type REAL and %qs is of type "
4993 : "INTEGER or UNSIGNED",
4994 0 : gfc_current_intrinsic_arg[2]->name,
4995 : gfc_current_intrinsic, &round->where,
4996 0 : gfc_current_intrinsic_arg[0]->name,
4997 0 : gfc_current_intrinsic_arg[1]->name);
4998 :
4999 0 : return false;
5000 : }
5001 : }
5002 :
5003 : return true;
5004 : }
5005 :
5006 :
5007 : bool
5008 641 : gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
5009 : {
5010 641 : if (!array_check (array, 0))
5011 : return false;
5012 :
5013 641 : if (!type_check (mask, 1, BT_LOGICAL))
5014 : return false;
5015 :
5016 641 : if (!gfc_check_conformance (array, mask,
5017 641 : _("arguments '%s' and '%s' for intrinsic '%s'"),
5018 641 : gfc_current_intrinsic_arg[0]->name,
5019 641 : gfc_current_intrinsic_arg[1]->name,
5020 : gfc_current_intrinsic))
5021 : return false;
5022 :
5023 640 : if (vector != NULL)
5024 : {
5025 213 : mpz_t array_size, vector_size;
5026 213 : bool have_array_size, have_vector_size;
5027 :
5028 213 : if (!same_type_check (array, 0, vector, 2))
5029 2 : return false;
5030 :
5031 213 : if (!rank_check (vector, 2, 1))
5032 : return false;
5033 :
5034 : /* VECTOR requires at least as many elements as MASK
5035 : has .TRUE. values. */
5036 213 : have_array_size = gfc_array_size(array, &array_size);
5037 213 : have_vector_size = gfc_array_size(vector, &vector_size);
5038 :
5039 213 : if (have_vector_size
5040 177 : && (mask->expr_type == EXPR_ARRAY
5041 174 : || (mask->expr_type == EXPR_CONSTANT
5042 42 : && have_array_size)))
5043 : {
5044 33 : int mask_true_values = 0;
5045 :
5046 33 : if (mask->expr_type == EXPR_ARRAY)
5047 : {
5048 3 : gfc_constructor *mask_ctor;
5049 3 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5050 42 : while (mask_ctor)
5051 : {
5052 36 : if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
5053 : {
5054 : mask_true_values = 0;
5055 : break;
5056 : }
5057 :
5058 36 : if (mask_ctor->expr->value.logical)
5059 6 : mask_true_values++;
5060 :
5061 36 : mask_ctor = gfc_constructor_next (mask_ctor);
5062 : }
5063 : }
5064 30 : else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
5065 12 : mask_true_values = mpz_get_si (array_size);
5066 :
5067 33 : if (mpz_get_si (vector_size) < mask_true_values)
5068 : {
5069 2 : gfc_error ("%qs argument of %qs intrinsic at %L must "
5070 : "provide at least as many elements as there "
5071 : "are .TRUE. values in %qs (%ld/%d)",
5072 2 : gfc_current_intrinsic_arg[2]->name,
5073 : gfc_current_intrinsic, &vector->where,
5074 2 : gfc_current_intrinsic_arg[1]->name,
5075 : mpz_get_si (vector_size), mask_true_values);
5076 2 : return false;
5077 : }
5078 : }
5079 :
5080 199 : if (have_array_size)
5081 151 : mpz_clear (array_size);
5082 211 : if (have_vector_size)
5083 175 : mpz_clear (vector_size);
5084 : }
5085 :
5086 : return true;
5087 : }
5088 :
5089 :
5090 : bool
5091 103 : gfc_check_parity (gfc_expr *mask, gfc_expr *dim)
5092 : {
5093 103 : if (!type_check (mask, 0, BT_LOGICAL))
5094 : return false;
5095 :
5096 101 : if (!array_check (mask, 0))
5097 : return false;
5098 :
5099 100 : if (!dim_check (dim, 1, false))
5100 : return false;
5101 :
5102 99 : if (!dim_rank_check (dim, mask, false))
5103 : return false;
5104 :
5105 : return true;
5106 : }
5107 :
5108 :
5109 : bool
5110 465 : gfc_check_precision (gfc_expr *x)
5111 : {
5112 465 : if (!real_or_complex_check (x, 0))
5113 : return false;
5114 :
5115 : return true;
5116 : }
5117 :
5118 :
5119 : bool
5120 5007 : gfc_check_present (gfc_expr *a)
5121 : {
5122 5007 : gfc_symbol *sym;
5123 :
5124 5007 : if (!variable_check (a, 0, true))
5125 : return false;
5126 :
5127 5007 : sym = a->symtree->n.sym;
5128 5007 : if (!sym->attr.dummy)
5129 : {
5130 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
5131 0 : "dummy variable", gfc_current_intrinsic_arg[0]->name,
5132 : gfc_current_intrinsic, &a->where);
5133 0 : return false;
5134 : }
5135 :
5136 : /* For CLASS, the optional attribute might be set at either location. */
5137 5007 : if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional)
5138 5007 : && !sym->attr.optional)
5139 : {
5140 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be of "
5141 : "an OPTIONAL dummy variable",
5142 0 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5143 : &a->where);
5144 0 : return false;
5145 : }
5146 :
5147 : /* 13.14.82 PRESENT(A)
5148 : ......
5149 : Argument. A shall be the name of an optional dummy argument that is
5150 : accessible in the subprogram in which the PRESENT function reference
5151 : appears... */
5152 :
5153 5007 : if (a->ref != NULL
5154 2326 : && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
5155 2325 : && (a->ref->u.ar.type == AR_FULL
5156 21 : || (a->ref->u.ar.type == AR_ELEMENT
5157 21 : && a->ref->u.ar.as->rank == 0))))
5158 : {
5159 2 : gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
5160 2 : "subobject of %qs", gfc_current_intrinsic_arg[0]->name,
5161 : gfc_current_intrinsic, &a->where, sym->name);
5162 2 : return false;
5163 : }
5164 :
5165 : return true;
5166 : }
5167 :
5168 :
5169 : bool
5170 61 : gfc_check_radix (gfc_expr *x)
5171 : {
5172 61 : if (!int_or_real_check (x, 0))
5173 : return false;
5174 :
5175 : return true;
5176 : }
5177 :
5178 :
5179 : bool
5180 185 : gfc_check_range (gfc_expr *x)
5181 : {
5182 185 : if (!numeric_check (x, 0))
5183 : return false;
5184 :
5185 : return true;
5186 : }
5187 :
5188 :
5189 : bool
5190 1360 : gfc_check_rank (gfc_expr *a)
5191 : {
5192 : /* Any data object is allowed; a "data object" is a "constant (4.1.3),
5193 : variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */
5194 :
5195 1360 : bool is_variable = true;
5196 :
5197 : /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
5198 1360 : if (a->expr_type == EXPR_FUNCTION)
5199 0 : is_variable = a->value.function.esym
5200 0 : ? a->value.function.esym->result->attr.pointer
5201 0 : : a->symtree->n.sym->result->attr.pointer;
5202 :
5203 1360 : if (a->expr_type == EXPR_OP
5204 1360 : || a->expr_type == EXPR_NULL
5205 1360 : || a->expr_type == EXPR_COMPCALL
5206 1360 : || a->expr_type == EXPR_PPC
5207 1360 : || a->ts.type == BT_PROCEDURE
5208 1360 : || !is_variable)
5209 : {
5210 0 : gfc_error ("The argument of the RANK intrinsic at %L must be a data "
5211 : "object", &a->where);
5212 0 : return false;
5213 : }
5214 :
5215 : return true;
5216 : }
5217 :
5218 :
5219 : bool
5220 3391 : gfc_check_real (gfc_expr *a, gfc_expr *kind)
5221 : {
5222 3391 : if (!kind_check (kind, 1, BT_REAL))
5223 : return false;
5224 :
5225 : /* BOZ is dealt with in gfc_simplify_real. */
5226 3391 : if (a->ts.type == BT_BOZ)
5227 : return true;
5228 :
5229 3306 : if (!numeric_check (a, 0))
5230 : return false;
5231 :
5232 : return true;
5233 : }
5234 :
5235 :
5236 : bool
5237 251 : gfc_check_reduce (gfc_expr *array, gfc_expr *operation, gfc_expr *dim,
5238 : gfc_expr *mask, gfc_expr *identity, gfc_expr *ordered)
5239 : {
5240 251 : if (array->ts.type == BT_CLASS)
5241 : {
5242 1 : gfc_error ("The ARRAY argument at %L of REDUCE shall not be polymorphic",
5243 : &array->where);
5244 1 : return false;
5245 : }
5246 :
5247 250 : if (!check_operation (operation, array, false))
5248 : return false;
5249 :
5250 236 : if (dim && (dim->rank || dim->ts.type != BT_INTEGER))
5251 : {
5252 2 : gfc_error ("The DIM argument at %L, if present, must be an integer "
5253 : "scalar", &dim->where);
5254 2 : return false;
5255 : }
5256 :
5257 234 : if (mask && (array->rank != mask->rank || mask->ts.type != BT_LOGICAL))
5258 : {
5259 2 : gfc_error ("The MASK argument at %L, if present, must be a logical "
5260 : "array with the same rank as ARRAY", &mask->where);
5261 2 : return false;
5262 : }
5263 :
5264 76 : if (mask
5265 76 : && !gfc_check_conformance (array, mask,
5266 76 : _("arguments '%s' and '%s' for intrinsic %s"),
5267 : "ARRAY", "MASK", "REDUCE"))
5268 : return false;
5269 :
5270 231 : if (mask && !identity)
5271 1 : gfc_warning (0, "MASK present at %L without IDENTITY", &mask->where);
5272 :
5273 231 : if (ordered && (ordered->rank || ordered->ts.type != BT_LOGICAL))
5274 : {
5275 0 : gfc_error ("The ORDERED argument at %L, if present, must be a logical "
5276 : "scalar", &ordered->where);
5277 0 : return false;
5278 : }
5279 :
5280 231 : if (identity && (identity->rank
5281 73 : || !gfc_compare_types (&array->ts, &identity->ts)))
5282 : {
5283 2 : gfc_error ("The IDENTITY argument at %L, if present, must be a scalar "
5284 : "with the same type as ARRAY", &identity->where);
5285 2 : return false;
5286 : }
5287 :
5288 : return true;
5289 : }
5290 :
5291 :
5292 : bool
5293 7 : gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
5294 : {
5295 7 : if (!type_check (path1, 0, BT_CHARACTER))
5296 : return false;
5297 7 : if (!kind_value_check (path1, 0, gfc_default_character_kind))
5298 : return false;
5299 :
5300 5 : if (!type_check (path2, 1, BT_CHARACTER))
5301 : return false;
5302 5 : if (!kind_value_check (path2, 1, gfc_default_character_kind))
5303 : return false;
5304 :
5305 : return true;
5306 : }
5307 :
5308 :
5309 : bool
5310 15 : gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
5311 : {
5312 15 : if (!type_check (path1, 0, BT_CHARACTER))
5313 : return false;
5314 15 : if (!kind_value_check (path1, 0, gfc_default_character_kind))
5315 : return false;
5316 :
5317 11 : if (!type_check (path2, 1, BT_CHARACTER))
5318 : return false;
5319 11 : if (!kind_value_check (path2, 1, gfc_default_character_kind))
5320 : return false;
5321 :
5322 9 : if (status == NULL)
5323 : return true;
5324 :
5325 7 : if (!type_check (status, 2, BT_INTEGER))
5326 : return false;
5327 :
5328 7 : if (!scalar_check (status, 2))
5329 : return false;
5330 :
5331 : return true;
5332 : }
5333 :
5334 :
5335 : bool
5336 1479 : gfc_check_repeat (gfc_expr *x, gfc_expr *y)
5337 : {
5338 1479 : if (!type_check (x, 0, BT_CHARACTER))
5339 : return false;
5340 :
5341 1479 : if (!scalar_check (x, 0))
5342 : return false;
5343 :
5344 1479 : if (!type_check (y, 0, BT_INTEGER))
5345 : return false;
5346 :
5347 1479 : if (!scalar_check (y, 1))
5348 : return false;
5349 :
5350 : return true;
5351 : }
5352 :
5353 :
5354 : bool
5355 9222 : gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
5356 : gfc_expr *pad, gfc_expr *order)
5357 : {
5358 9222 : mpz_t size;
5359 9222 : mpz_t nelems;
5360 9222 : int shape_size;
5361 9222 : bool shape_is_const;
5362 :
5363 9222 : if (!array_check (source, 0))
5364 : return false;
5365 :
5366 9221 : if (!rank_check (shape, 1, 1))
5367 : return false;
5368 :
5369 9221 : if (!type_check (shape, 1, BT_INTEGER))
5370 : return false;
5371 :
5372 9221 : if (!gfc_array_size (shape, &size))
5373 : {
5374 0 : gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
5375 : "array of constant size", &shape->where);
5376 0 : return false;
5377 : }
5378 :
5379 9221 : shape_size = mpz_get_ui (size);
5380 9221 : mpz_clear (size);
5381 :
5382 9221 : if (shape_size <= 0)
5383 : {
5384 1 : gfc_error ("%qs argument of %qs intrinsic at %L is empty",
5385 1 : gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5386 : &shape->where);
5387 1 : return false;
5388 : }
5389 9220 : else if (shape_size > GFC_MAX_DIMENSIONS)
5390 : {
5391 1 : gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
5392 : "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
5393 1 : return false;
5394 : }
5395 :
5396 9219 : gfc_simplify_expr (shape, 0);
5397 9219 : shape_is_const = gfc_is_constant_array_expr (shape);
5398 :
5399 9219 : if (shape->expr_type == EXPR_ARRAY && shape_is_const)
5400 : {
5401 : gfc_expr *e;
5402 : int i, extent;
5403 25194 : for (i = 0; i < shape_size; ++i)
5404 : {
5405 17569 : e = gfc_constructor_lookup_expr (shape->value.constructor, i);
5406 17569 : if (e == NULL)
5407 : break;
5408 17569 : if (e->expr_type != EXPR_CONSTANT)
5409 0 : continue;
5410 :
5411 17569 : gfc_extract_int (e, &extent);
5412 17569 : if (extent < 0)
5413 : {
5414 4 : gfc_error ("%qs argument of %qs intrinsic at %L has "
5415 : "negative element (%d)",
5416 4 : gfc_current_intrinsic_arg[1]->name,
5417 : gfc_current_intrinsic, &shape->where, extent);
5418 4 : return false;
5419 : }
5420 : }
5421 : }
5422 :
5423 9215 : if (pad != NULL)
5424 : {
5425 367 : if (!same_type_check (source, 0, pad, 2))
5426 : return false;
5427 :
5428 367 : if (!array_check (pad, 2))
5429 : return false;
5430 : }
5431 :
5432 9215 : if (order != NULL)
5433 : {
5434 136 : if (!array_check (order, 3))
5435 : return false;
5436 :
5437 136 : if (!type_check (order, 3, BT_INTEGER))
5438 : return false;
5439 :
5440 135 : if (order->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (order))
5441 : {
5442 : int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
5443 : gfc_expr *e;
5444 :
5445 1232 : for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
5446 1155 : perm[i] = 0;
5447 :
5448 77 : gfc_array_size (order, &size);
5449 77 : order_size = mpz_get_ui (size);
5450 77 : mpz_clear (size);
5451 :
5452 77 : if (order_size != shape_size)
5453 : {
5454 1 : gfc_error ("%qs argument of %qs intrinsic at %L "
5455 : "has wrong number of elements (%d/%d)",
5456 1 : gfc_current_intrinsic_arg[3]->name,
5457 : gfc_current_intrinsic, &order->where,
5458 : order_size, shape_size);
5459 3 : return false;
5460 : }
5461 :
5462 232 : for (i = 1; i <= order_size; ++i)
5463 : {
5464 158 : e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
5465 158 : if (e->expr_type != EXPR_CONSTANT)
5466 0 : continue;
5467 :
5468 158 : gfc_extract_int (e, &dim);
5469 :
5470 158 : if (dim < 1 || dim > order_size)
5471 : {
5472 1 : gfc_error ("%qs argument of %qs intrinsic at %L "
5473 : "has out-of-range dimension (%d)",
5474 1 : gfc_current_intrinsic_arg[3]->name,
5475 : gfc_current_intrinsic, &e->where, dim);
5476 1 : return false;
5477 : }
5478 :
5479 157 : if (perm[dim-1] != 0)
5480 : {
5481 1 : gfc_error ("%qs argument of %qs intrinsic at %L has "
5482 : "invalid permutation of dimensions (dimension "
5483 : "%qd duplicated)",
5484 1 : gfc_current_intrinsic_arg[3]->name,
5485 : gfc_current_intrinsic, &e->where, dim);
5486 1 : return false;
5487 : }
5488 :
5489 156 : perm[dim-1] = 1;
5490 : }
5491 : }
5492 : }
5493 :
5494 9211 : if (pad == NULL && shape->expr_type == EXPR_ARRAY && shape_is_const
5495 7305 : && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
5496 1907 : && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
5497 : {
5498 : /* Check the match in size between source and destination. */
5499 7304 : if (gfc_array_size (source, &nelems))
5500 : {
5501 7067 : gfc_constructor *c;
5502 7067 : bool test;
5503 :
5504 :
5505 7067 : mpz_init_set_ui (size, 1);
5506 7067 : for (c = gfc_constructor_first (shape->value.constructor);
5507 23225 : c; c = gfc_constructor_next (c))
5508 16158 : mpz_mul (size, size, c->expr->value.integer);
5509 :
5510 7067 : test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
5511 7067 : mpz_clear (nelems);
5512 7067 : mpz_clear (size);
5513 :
5514 7067 : if (test)
5515 : {
5516 11 : gfc_error ("Without padding, there are not enough elements "
5517 : "in the intrinsic RESHAPE source at %L to match "
5518 : "the shape", &source->where);
5519 11 : return false;
5520 : }
5521 : }
5522 : }
5523 :
5524 : return true;
5525 : }
5526 :
5527 :
5528 : bool
5529 764 : gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
5530 : {
5531 764 : if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
5532 : {
5533 4 : gfc_error ("%qs argument of %qs intrinsic at %L "
5534 : "cannot be of type %s",
5535 4 : gfc_current_intrinsic_arg[0]->name,
5536 : gfc_current_intrinsic,
5537 : &a->where, gfc_typename (a));
5538 4 : return false;
5539 : }
5540 :
5541 760 : if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
5542 : {
5543 0 : gfc_error ("%qs argument of %qs intrinsic at %L "
5544 : "must be of an extensible type",
5545 0 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5546 : &a->where);
5547 0 : return false;
5548 : }
5549 :
5550 760 : if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
5551 : {
5552 0 : gfc_error ("%qs argument of %qs intrinsic at %L "
5553 : "cannot be of type %s",
5554 0 : gfc_current_intrinsic_arg[0]->name,
5555 : gfc_current_intrinsic,
5556 : &b->where, gfc_typename (b));
5557 0 : return false;
5558 : }
5559 :
5560 760 : if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
5561 : {
5562 2 : gfc_error ("%qs argument of %qs intrinsic at %L "
5563 : "must be of an extensible type",
5564 2 : gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
5565 : &b->where);
5566 2 : return false;
5567 : }
5568 :
5569 : return true;
5570 : }
5571 :
5572 :
5573 : bool
5574 84 : gfc_check_scale (gfc_expr *x, gfc_expr *i)
5575 : {
5576 84 : if (!type_check (x, 0, BT_REAL))
5577 : return false;
5578 :
5579 84 : if (!type_check (i, 1, BT_INTEGER))
5580 : return false;
5581 :
5582 : return true;
5583 : }
5584 :
5585 :
5586 : bool
5587 418 : gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
5588 : {
5589 418 : if (!type_check (x, 0, BT_CHARACTER))
5590 : return false;
5591 :
5592 418 : if (!type_check (y, 1, BT_CHARACTER))
5593 : return false;
5594 :
5595 418 : if (z != NULL && !type_check (z, 2, BT_LOGICAL))
5596 : return false;
5597 :
5598 418 : if (!kind_check (kind, 3, BT_INTEGER))
5599 : return false;
5600 418 : if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
5601 : "with KIND argument at %L",
5602 : gfc_current_intrinsic, &kind->where))
5603 : return false;
5604 :
5605 418 : if (!same_type_check (x, 0, y, 1))
5606 : return false;
5607 :
5608 : return true;
5609 : }
5610 :
5611 : bool
5612 102 : gfc_check_split (gfc_expr *string, gfc_expr *set, gfc_expr *pos, gfc_expr *back)
5613 : {
5614 102 : if (!type_check (string, 0, BT_CHARACTER))
5615 : return false;
5616 :
5617 102 : if (!type_check (set, 1, BT_CHARACTER))
5618 : return false;
5619 :
5620 102 : if (!type_check (pos, 2, BT_INTEGER) || !scalar_check (pos, 2))
5621 0 : return false;
5622 :
5623 102 : if (back != NULL
5624 102 : && (!type_check (back, 3, BT_LOGICAL) || !scalar_check (back, 3)))
5625 0 : return false;
5626 :
5627 102 : if (!same_type_check (string, 0, set, 1))
5628 : return false;
5629 :
5630 : return true;
5631 : }
5632 :
5633 : bool
5634 32 : gfc_check_secnds (gfc_expr *r)
5635 : {
5636 32 : if (!type_check (r, 0, BT_REAL))
5637 : return false;
5638 :
5639 32 : if (!kind_value_check (r, 0, 4))
5640 : return false;
5641 :
5642 32 : if (!scalar_check (r, 0))
5643 : return false;
5644 :
5645 : return true;
5646 : }
5647 :
5648 :
5649 : bool
5650 227 : gfc_check_selected_char_kind (gfc_expr *name)
5651 : {
5652 227 : if (!type_check (name, 0, BT_CHARACTER))
5653 : return false;
5654 :
5655 226 : if (!kind_value_check (name, 0, gfc_default_character_kind))
5656 : return false;
5657 :
5658 224 : if (!scalar_check (name, 0))
5659 : return false;
5660 :
5661 : return true;
5662 : }
5663 :
5664 :
5665 : bool
5666 352 : gfc_check_selected_int_kind (gfc_expr *r)
5667 : {
5668 352 : if (!type_check (r, 0, BT_INTEGER))
5669 : return false;
5670 :
5671 352 : if (!scalar_check (r, 0))
5672 : return false;
5673 :
5674 : return true;
5675 : }
5676 :
5677 : bool
5678 728 : gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
5679 : {
5680 728 : if (p == NULL && r == NULL
5681 728 : && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
5682 : " neither %<P%> nor %<R%> argument at %L",
5683 : gfc_current_intrinsic_where))
5684 : return false;
5685 :
5686 727 : if (p)
5687 : {
5688 685 : if (!type_check (p, 0, BT_INTEGER))
5689 : return false;
5690 :
5691 685 : if (!scalar_check (p, 0))
5692 : return false;
5693 : }
5694 :
5695 726 : if (r)
5696 : {
5697 244 : if (!type_check (r, 1, BT_INTEGER))
5698 : return false;
5699 :
5700 244 : if (!scalar_check (r, 1))
5701 : return false;
5702 : }
5703 :
5704 725 : if (radix)
5705 : {
5706 53 : if (!type_check (radix, 1, BT_INTEGER))
5707 : return false;
5708 :
5709 53 : if (!scalar_check (radix, 1))
5710 : return false;
5711 :
5712 53 : if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
5713 : "RADIX argument at %L", gfc_current_intrinsic,
5714 : &radix->where))
5715 : return false;
5716 : }
5717 :
5718 : return true;
5719 : }
5720 :
5721 :
5722 : bool
5723 412 : gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
5724 : {
5725 412 : if (!type_check (x, 0, BT_REAL))
5726 : return false;
5727 :
5728 412 : if (!type_check (i, 1, BT_INTEGER))
5729 : return false;
5730 :
5731 : return true;
5732 : }
5733 :
5734 :
5735 : bool
5736 7273 : gfc_check_shape (gfc_expr *source, gfc_expr *kind)
5737 : {
5738 7273 : gfc_array_ref *ar;
5739 :
5740 7273 : if (gfc_invalid_null_arg (source))
5741 : return false;
5742 :
5743 7272 : if (!kind_check (kind, 1, BT_INTEGER))
5744 : return false;
5745 7271 : if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
5746 : "with KIND argument at %L",
5747 : gfc_current_intrinsic, &kind->where))
5748 : return false;
5749 :
5750 7271 : if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
5751 : return true;
5752 :
5753 7186 : if (source->ref == NULL)
5754 : return false;
5755 :
5756 7186 : ar = gfc_find_array_ref (source);
5757 :
5758 7186 : if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
5759 : {
5760 1 : gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
5761 : "an assumed size array", &source->where);
5762 1 : return false;
5763 : }
5764 :
5765 : return true;
5766 : }
5767 :
5768 :
5769 : bool
5770 6921 : gfc_check_shift (gfc_expr *i, gfc_expr *shift)
5771 : {
5772 6921 : if (flag_unsigned)
5773 : {
5774 156 : if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
5775 : return false;
5776 : }
5777 : else
5778 : {
5779 6765 : if (!type_check (i, 0, BT_INTEGER))
5780 : return false;
5781 : }
5782 :
5783 6921 : if (!type_check (shift, 0, BT_INTEGER))
5784 : return false;
5785 :
5786 6921 : if (!nonnegative_check ("SHIFT", shift))
5787 : return false;
5788 :
5789 6921 : if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true))
5790 : return false;
5791 :
5792 : return true;
5793 : }
5794 :
5795 :
5796 : bool
5797 327 : gfc_check_sign (gfc_expr *a, gfc_expr *b)
5798 : {
5799 327 : if (!int_or_real_check (a, 0))
5800 : return false;
5801 :
5802 327 : if (!same_type_check (a, 0, b, 1))
5803 : return false;
5804 :
5805 : return true;
5806 : }
5807 :
5808 :
5809 : bool
5810 12351 : gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5811 : {
5812 12351 : if (!array_check (array, 0))
5813 : return false;
5814 :
5815 12345 : if (!dim_check (dim, 1, true))
5816 : return false;
5817 :
5818 12344 : if (!dim_rank_check (dim, array, 0))
5819 : return false;
5820 :
5821 12340 : if (!kind_check (kind, 2, BT_INTEGER))
5822 : return false;
5823 12339 : if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
5824 : "with KIND argument at %L",
5825 : gfc_current_intrinsic, &kind->where))
5826 : return false;
5827 :
5828 :
5829 : return true;
5830 : }
5831 :
5832 :
5833 : bool
5834 1839 : gfc_check_sizeof (gfc_expr *arg)
5835 : {
5836 1839 : if (gfc_invalid_null_arg (arg))
5837 : return false;
5838 :
5839 1838 : if (arg->ts.type == BT_PROCEDURE)
5840 : {
5841 5 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
5842 5 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5843 : &arg->where);
5844 5 : return false;
5845 : }
5846 :
5847 1833 : if (illegal_boz_arg (arg))
5848 : return false;
5849 :
5850 : /* TYPE(*) is acceptable if and only if it uses an array descriptor. */
5851 1832 : if (arg->ts.type == BT_ASSUMED
5852 173 : && (arg->symtree->n.sym->as == NULL
5853 172 : || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE
5854 172 : && arg->symtree->n.sym->as->type != AS_DEFERRED
5855 106 : && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
5856 : {
5857 1 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
5858 1 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5859 : &arg->where);
5860 1 : return false;
5861 : }
5862 :
5863 1831 : if (arg->rank && arg->expr_type == EXPR_VARIABLE
5864 1093 : && arg->symtree->n.sym->as != NULL
5865 675 : && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
5866 1 : && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
5867 : {
5868 1 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
5869 1 : "assumed-size array", gfc_current_intrinsic_arg[0]->name,
5870 : gfc_current_intrinsic, &arg->where);
5871 1 : return false;
5872 : }
5873 :
5874 : return true;
5875 : }
5876 :
5877 :
5878 : /* Check whether an expression is interoperable. When returning false,
5879 : msg is set to a string telling why the expression is not interoperable,
5880 : otherwise, it is set to NULL. The msg string can be used in diagnostics.
5881 : If c_loc is true, character with len > 1 are allowed (cf. Fortran
5882 : 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
5883 : arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
5884 : are permitted. */
5885 :
5886 : static bool
5887 4640 : is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
5888 : {
5889 4640 : *msg = NULL;
5890 :
5891 4640 : if (expr->expr_type == EXPR_NULL && expr->ts.type == BT_UNKNOWN)
5892 : {
5893 1 : *msg = _("NULL() is not interoperable");
5894 1 : return false;
5895 : }
5896 :
5897 4639 : if (expr->ts.type == BT_BOZ)
5898 : {
5899 1 : *msg = _("BOZ literal constant");
5900 1 : return false;
5901 : }
5902 :
5903 4638 : if (expr->ts.type == BT_CLASS)
5904 : {
5905 0 : *msg = _("Expression is polymorphic");
5906 0 : return false;
5907 : }
5908 :
5909 4638 : if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c
5910 41 : && !expr->ts.u.derived->ts.is_iso_c)
5911 : {
5912 41 : *msg = _("Expression is a noninteroperable derived type");
5913 41 : return false;
5914 : }
5915 :
5916 4597 : if (expr->ts.type == BT_PROCEDURE)
5917 : {
5918 4 : *msg = _("Procedure unexpected as argument");
5919 4 : return false;
5920 : }
5921 :
5922 4593 : if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL)
5923 : {
5924 : int i;
5925 24 : for (i = 0; gfc_logical_kinds[i].kind; i++)
5926 24 : if (gfc_logical_kinds[i].kind == expr->ts.kind)
5927 : return true;
5928 0 : *msg = _("Extension to use a non-C_Bool-kind LOGICAL");
5929 0 : return false;
5930 : }
5931 :
5932 5259 : if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
5933 4728 : && expr->ts.kind != 1)
5934 : {
5935 48 : *msg = _("Extension to use a non-C_CHAR-kind CHARACTER");
5936 48 : return false;
5937 : }
5938 :
5939 4533 : if (expr->ts.type == BT_CHARACTER) {
5940 107 : if (expr->ts.deferred)
5941 : {
5942 : /* TS 29113 allows deferred-length strings as dummy arguments,
5943 : but it is not an interoperable type. */
5944 1 : *msg = "Expression shall not be a deferred-length string";
5945 1 : return false;
5946 : }
5947 :
5948 106 : if (expr->ts.u.cl && expr->ts.u.cl->length
5949 155 : && !gfc_simplify_expr (expr->ts.u.cl->length, 0))
5950 0 : gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5951 :
5952 106 : if (!c_loc
5953 29 : && expr->ts.u.cl
5954 135 : && !gfc_length_one_character_type_p (&expr->ts))
5955 : {
5956 0 : *msg = _("Type shall have a character length of 1");
5957 0 : return false;
5958 : }
5959 : }
5960 :
5961 : /* Note: The following checks are about interoperatable variables, Fortran
5962 : 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more
5963 : is allowed, e.g. assumed-shape arrays with TS 29113. */
5964 :
5965 4532 : if (gfc_is_coarray (expr))
5966 : {
5967 0 : *msg = _("Coarrays are not interoperable");
5968 0 : return false;
5969 : }
5970 :
5971 : /* Checks for C_SIZEOF need to take into account edits to 18-007r1, see
5972 : https://j3-fortran.org/doc/year/22/22-101r1.txt . */
5973 4532 : if (!c_loc && !c_f_ptr && expr->rank > 0 && expr->expr_type == EXPR_VARIABLE)
5974 : {
5975 95 : gfc_array_ref *ar = gfc_find_array_ref (expr);
5976 95 : if (ar->type == AR_FULL && ar->as->type == AS_ASSUMED_SIZE)
5977 : {
5978 2 : *msg = _("Assumed-size arrays are not interoperable");
5979 2 : return false;
5980 : }
5981 : }
5982 :
5983 : return true;
5984 : }
5985 :
5986 :
5987 : bool
5988 426 : gfc_check_c_sizeof (gfc_expr *arg)
5989 : {
5990 426 : const char *msg;
5991 :
5992 426 : if (!is_c_interoperable (arg, &msg, false, false))
5993 : {
5994 9 : gfc_error ("%qs argument of %qs intrinsic at %L must be an "
5995 : "interoperable data entity: %s",
5996 9 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
5997 : &arg->where, msg);
5998 9 : return false;
5999 : }
6000 :
6001 417 : if (arg->ts.type == BT_ASSUMED)
6002 : {
6003 0 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
6004 : "TYPE(*)",
6005 0 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
6006 : &arg->where);
6007 0 : return false;
6008 : }
6009 :
6010 417 : if (arg->rank && arg->expr_type == EXPR_VARIABLE
6011 95 : && arg->symtree->n.sym->as != NULL
6012 93 : && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
6013 1 : && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
6014 : {
6015 0 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
6016 0 : "assumed-size array", gfc_current_intrinsic_arg[0]->name,
6017 : gfc_current_intrinsic, &arg->where);
6018 0 : return false;
6019 : }
6020 :
6021 : return true;
6022 : }
6023 :
6024 :
6025 : /* Helper functions check_c_ptr_1 and check_c_ptr_2
6026 : used in gfc_check_c_associated. */
6027 :
6028 : static inline
6029 2051 : bool check_c_ptr_1 (gfc_expr *c_ptr_1)
6030 : {
6031 2051 : if ((c_ptr_1->ts.type == BT_VOID)
6032 3 : && (c_ptr_1->expr_type == EXPR_FUNCTION))
6033 : return true;
6034 :
6035 2048 : if (c_ptr_1->ts.type != BT_DERIVED
6036 2039 : || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
6037 2038 : || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
6038 159 : && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
6039 10 : goto check_1_error;
6040 :
6041 2038 : if ((c_ptr_1->ts.type == BT_DERIVED)
6042 : && (c_ptr_1->expr_type == EXPR_STRUCTURE)
6043 : && (c_ptr_1->ts.u.derived->intmod_sym_id
6044 : == ISOCBINDING_NULL_FUNPTR))
6045 : goto check_1_error;
6046 :
6047 2038 : if (scalar_check (c_ptr_1, 0))
6048 : return true;
6049 : else
6050 : /* Return since the check_1_error message may not apply here. */
6051 : return false;
6052 :
6053 10 : check_1_error:
6054 :
6055 10 : gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
6056 : "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
6057 10 : return false;
6058 : }
6059 :
6060 : static inline
6061 374 : bool check_c_ptr_2 (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
6062 : {
6063 374 : switch (c_ptr_2->ts.type)
6064 : {
6065 4 : case BT_VOID:
6066 4 : if (c_ptr_2->expr_type == EXPR_FUNCTION)
6067 : {
6068 4 : if ((c_ptr_1->ts.type == BT_DERIVED)
6069 4 : && c_ptr_1->expr_type == EXPR_STRUCTURE
6070 2 : && (c_ptr_1->ts.u.derived->intmod_sym_id
6071 : == ISOCBINDING_FUNPTR))
6072 1 : goto check_2_error;
6073 : }
6074 : break;
6075 :
6076 363 : case BT_DERIVED:
6077 363 : if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
6078 3 : && (c_ptr_2->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR)
6079 1 : && (c_ptr_1->ts.type == BT_VOID)
6080 1 : && (c_ptr_1->expr_type == EXPR_FUNCTION))
6081 1 : return scalar_check (c_ptr_2, 1);
6082 :
6083 362 : if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
6084 2 : && (c_ptr_1->ts.type == BT_VOID)
6085 1 : && (c_ptr_1->expr_type == EXPR_FUNCTION))
6086 1 : goto check_2_error;
6087 :
6088 361 : if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING)
6089 1 : goto check_2_error;
6090 :
6091 360 : if (c_ptr_1->ts.type == BT_DERIVED
6092 358 : && (c_ptr_1->ts.u.derived->intmod_sym_id
6093 358 : != c_ptr_2->ts.u.derived->intmod_sym_id))
6094 2 : goto check_2_error;
6095 : break;
6096 :
6097 7 : default:
6098 7 : goto check_2_error;
6099 : }
6100 :
6101 361 : if (scalar_check (c_ptr_2, 1))
6102 : return true;
6103 : else
6104 : /* Return since the check_2_error message may not apply here. */
6105 : return false;
6106 :
6107 12 : check_2_error:
6108 :
6109 12 : gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
6110 : "same type as C_PTR_1, found %s instead of %s", &c_ptr_2->where,
6111 : gfc_typename (&c_ptr_2->ts), gfc_typename (&c_ptr_1->ts));
6112 :
6113 12 : return false;
6114 : }
6115 :
6116 :
6117 : bool
6118 2063 : gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
6119 : {
6120 2063 : if (c_ptr_2)
6121 : {
6122 374 : if (check_c_ptr_2 (c_ptr_1, c_ptr_2))
6123 362 : return check_c_ptr_1 (c_ptr_1);
6124 : else
6125 : return false;
6126 : }
6127 : else
6128 1689 : return check_c_ptr_1 (c_ptr_1);
6129 : }
6130 :
6131 :
6132 : bool
6133 646 : gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape,
6134 : gfc_expr *lower)
6135 : {
6136 646 : symbol_attribute attr;
6137 646 : const char *msg;
6138 :
6139 646 : if (cptr->ts.type != BT_DERIVED
6140 646 : || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
6141 646 : || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
6142 : {
6143 2 : gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
6144 : "type TYPE(C_PTR)", &cptr->where);
6145 2 : return false;
6146 : }
6147 :
6148 644 : if (!scalar_check (cptr, 0))
6149 : return false;
6150 :
6151 644 : attr = gfc_expr_attr (fptr);
6152 :
6153 644 : if (!attr.pointer)
6154 : {
6155 1 : gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer",
6156 : &fptr->where);
6157 1 : return false;
6158 : }
6159 :
6160 643 : if (fptr->ts.type == BT_CLASS)
6161 : {
6162 1 : gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
6163 : &fptr->where);
6164 1 : return false;
6165 : }
6166 :
6167 642 : if (gfc_is_coindexed (fptr))
6168 : {
6169 0 : gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
6170 : "coindexed", &fptr->where);
6171 0 : return false;
6172 : }
6173 :
6174 642 : if (fptr->rank == 0 && shape)
6175 : {
6176 1 : gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
6177 : "FPTR", &fptr->where);
6178 1 : return false;
6179 : }
6180 641 : else if (fptr->rank && !shape)
6181 : {
6182 1 : gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
6183 : "FPTR at %L", &fptr->where);
6184 1 : return false;
6185 : }
6186 :
6187 640 : if (shape && !rank_check (shape, 2, 1))
6188 : return false;
6189 :
6190 639 : if (shape && !type_check (shape, 2, BT_INTEGER))
6191 : return false;
6192 :
6193 638 : if (shape)
6194 : {
6195 491 : mpz_t size;
6196 491 : if (gfc_array_size (shape, &size))
6197 : {
6198 490 : if (mpz_cmp_ui (size, fptr->rank) != 0)
6199 : {
6200 0 : mpz_clear (size);
6201 0 : gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
6202 : "size as the RANK of FPTR", &shape->where);
6203 0 : return false;
6204 : }
6205 490 : mpz_clear (size);
6206 : }
6207 : }
6208 :
6209 638 : if (lower
6210 638 : && !gfc_notify_std (GFC_STD_F2023, "LOWER argument at %L to C_F_POINTER",
6211 : &lower->where))
6212 : return false;
6213 :
6214 637 : if (!shape && lower)
6215 : {
6216 0 : gfc_error ("Unexpected LOWER argument at %L to C_F_POINTER "
6217 : "with scalar FPTR",
6218 : &lower->where);
6219 0 : return false;
6220 : }
6221 :
6222 637 : if (lower && !rank_check (lower, 3, 1))
6223 : return false;
6224 :
6225 636 : if (lower && !type_check (lower, 3, BT_INTEGER))
6226 : return false;
6227 :
6228 635 : if (lower)
6229 : {
6230 12 : mpz_t size;
6231 12 : if (gfc_array_size (lower, &size))
6232 : {
6233 12 : if (mpz_cmp_ui (size, fptr->rank) != 0)
6234 : {
6235 0 : mpz_clear (size);
6236 0 : gfc_error (
6237 : "LOWER argument at %L to C_F_POINTER must have the same "
6238 : "size as the RANK of FPTR",
6239 : &lower->where);
6240 0 : return false;
6241 : }
6242 12 : mpz_clear (size);
6243 : }
6244 : }
6245 :
6246 635 : if (fptr->ts.type == BT_CLASS)
6247 : {
6248 0 : gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
6249 0 : return false;
6250 : }
6251 :
6252 635 : if (fptr->ts.type == BT_PROCEDURE && attr.function)
6253 : {
6254 2 : gfc_error ("FPTR argument to C_F_POINTER at %L is a function "
6255 : "returning a pointer", &fptr->where);
6256 2 : return false;
6257 : }
6258 :
6259 633 : if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true))
6260 13 : return gfc_notify_std (GFC_STD_F2018,
6261 : "Noninteroperable array FPTR argument to "
6262 13 : "C_F_POINTER at %L: %s", &fptr->where, msg);
6263 :
6264 : return true;
6265 : }
6266 :
6267 :
6268 : bool
6269 62 : gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
6270 : {
6271 62 : symbol_attribute attr;
6272 :
6273 62 : if (cptr->ts.type != BT_DERIVED
6274 62 : || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
6275 62 : || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
6276 : {
6277 3 : gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
6278 : "type TYPE(C_FUNPTR)", &cptr->where);
6279 3 : return false;
6280 : }
6281 :
6282 59 : if (!scalar_check (cptr, 0))
6283 : return false;
6284 :
6285 59 : attr = gfc_expr_attr (fptr);
6286 :
6287 59 : if (!attr.proc_pointer)
6288 : {
6289 0 : gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
6290 : "pointer", &fptr->where);
6291 0 : return false;
6292 : }
6293 :
6294 59 : if (gfc_is_coindexed (fptr))
6295 : {
6296 0 : gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
6297 : "coindexed", &fptr->where);
6298 0 : return false;
6299 : }
6300 :
6301 59 : if (!attr.is_bind_c)
6302 47 : return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
6303 47 : "pointer at %L to C_F_PROCPOINTER", &fptr->where);
6304 :
6305 : return true;
6306 : }
6307 :
6308 :
6309 : bool
6310 241 : gfc_check_c_funloc (gfc_expr *x)
6311 : {
6312 241 : symbol_attribute attr;
6313 :
6314 241 : if (gfc_is_coindexed (x))
6315 : {
6316 0 : gfc_error ("Argument X at %L to C_FUNLOC shall not be "
6317 : "coindexed", &x->where);
6318 0 : return false;
6319 : }
6320 :
6321 241 : attr = gfc_expr_attr (x);
6322 :
6323 241 : if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
6324 123 : && x->symtree->n.sym == x->symtree->n.sym->result)
6325 56 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
6326 34 : if (x->symtree->n.sym == ns->proc_name)
6327 : {
6328 3 : gfc_error ("Function result %qs at %L is invalid as X argument "
6329 : "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
6330 3 : return false;
6331 : }
6332 :
6333 238 : if (attr.flavor != FL_PROCEDURE)
6334 : {
6335 1 : gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
6336 : "or a procedure pointer", &x->where);
6337 1 : return false;
6338 : }
6339 :
6340 237 : if (!attr.is_bind_c)
6341 96 : return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
6342 96 : "at %L to C_FUNLOC", &x->where);
6343 : return true;
6344 : }
6345 :
6346 :
6347 : bool
6348 3733 : gfc_check_c_loc (gfc_expr *x)
6349 : {
6350 3733 : symbol_attribute attr;
6351 3733 : const char *msg;
6352 :
6353 3733 : if (gfc_is_coindexed (x))
6354 : {
6355 1 : gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
6356 1 : return false;
6357 : }
6358 :
6359 3732 : if (x->ts.type == BT_CLASS)
6360 : {
6361 1 : gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
6362 : &x->where);
6363 1 : return false;
6364 : }
6365 :
6366 3731 : attr = gfc_expr_attr (x);
6367 :
6368 3731 : if (!attr.pointer
6369 2383 : && (x->expr_type != EXPR_VARIABLE || !attr.target
6370 2379 : || attr.flavor == FL_PARAMETER))
6371 : {
6372 4 : gfc_error ("Argument X at %L to C_LOC shall have either "
6373 : "the POINTER or the TARGET attribute", &x->where);
6374 4 : return false;
6375 : }
6376 :
6377 3727 : if (x->ts.type == BT_CHARACTER
6378 3727 : && gfc_var_strlen (x) == 0)
6379 : {
6380 0 : gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
6381 : "string", &x->where);
6382 0 : return false;
6383 : }
6384 :
6385 3727 : if (!is_c_interoperable (x, &msg, true, false))
6386 : {
6387 76 : if (x->ts.type == BT_CLASS)
6388 : {
6389 0 : gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
6390 : &x->where);
6391 0 : return false;
6392 : }
6393 :
6394 76 : if (x->rank
6395 76 : && !gfc_notify_std (GFC_STD_F2018,
6396 : "Noninteroperable array at %L as"
6397 : " argument to C_LOC: %s", &x->where, msg))
6398 : return false;
6399 : }
6400 3651 : else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
6401 : {
6402 7 : gfc_array_ref *ar = gfc_find_array_ref (x);
6403 :
6404 6 : if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
6405 5 : && !attr.allocatable
6406 11 : && !gfc_notify_std (GFC_STD_F2008,
6407 : "Array of interoperable type at %L "
6408 : "to C_LOC which is nonallocatable and neither "
6409 : "assumed size nor explicit size", &x->where))
6410 : return false;
6411 3 : else if (ar->type != AR_FULL
6412 3 : && !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
6413 : "to C_LOC", &x->where))
6414 : return false;
6415 : }
6416 :
6417 : return true;
6418 : }
6419 :
6420 :
6421 : bool
6422 28 : gfc_check_sleep_sub (gfc_expr *seconds)
6423 : {
6424 28 : if (!type_check (seconds, 0, BT_INTEGER))
6425 : return false;
6426 :
6427 28 : if (!scalar_check (seconds, 0))
6428 : return false;
6429 :
6430 : return true;
6431 : }
6432 :
6433 : bool
6434 3 : gfc_check_sngl (gfc_expr *a)
6435 : {
6436 3 : if (!type_check (a, 0, BT_REAL))
6437 : return false;
6438 :
6439 3 : if ((a->ts.kind != gfc_default_double_kind)
6440 3 : && !gfc_notify_std (GFC_STD_GNU, "non double precision "
6441 : "REAL argument to %s intrinsic at %L",
6442 : gfc_current_intrinsic, &a->where))
6443 : return false;
6444 :
6445 : return true;
6446 : }
6447 :
6448 : bool
6449 644 : gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
6450 : {
6451 644 : if (gfc_invalid_null_arg (source))
6452 : return false;
6453 :
6454 643 : if (source->rank >= GFC_MAX_DIMENSIONS)
6455 : {
6456 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be less "
6457 0 : "than rank %d", gfc_current_intrinsic_arg[0]->name,
6458 : gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
6459 :
6460 0 : return false;
6461 : }
6462 :
6463 643 : if (dim == NULL)
6464 : return false;
6465 :
6466 643 : if (!dim_check (dim, 1, false))
6467 : return false;
6468 :
6469 : /* dim_rank_check() does not apply here. */
6470 643 : if (dim
6471 643 : && dim->expr_type == EXPR_CONSTANT
6472 643 : && (mpz_cmp_ui (dim->value.integer, 1) < 0
6473 642 : || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
6474 : {
6475 2 : gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
6476 2 : "dimension index", gfc_current_intrinsic_arg[1]->name,
6477 : gfc_current_intrinsic, &dim->where);
6478 2 : return false;
6479 : }
6480 :
6481 641 : if (!type_check (ncopies, 2, BT_INTEGER))
6482 : return false;
6483 :
6484 641 : if (!scalar_check (ncopies, 2))
6485 : return false;
6486 :
6487 : return true;
6488 : }
6489 :
6490 :
6491 : /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
6492 : functions). */
6493 :
6494 : bool
6495 157 : arg_strlen_is_zero (gfc_expr *c, int n)
6496 : {
6497 157 : if (gfc_var_strlen (c) == 0)
6498 : {
6499 2 : gfc_error ("%qs argument of %qs intrinsic at %L must have "
6500 2 : "length at least 1", gfc_current_intrinsic_arg[n]->name,
6501 : gfc_current_intrinsic, &c->where);
6502 2 : return true;
6503 : }
6504 : return false;
6505 : }
6506 :
6507 : bool
6508 155 : gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
6509 : {
6510 155 : if (!type_check (unit, 0, BT_INTEGER))
6511 : return false;
6512 :
6513 155 : if (!scalar_check (unit, 0))
6514 : return false;
6515 :
6516 155 : if (!type_check (c, 1, BT_CHARACTER))
6517 : return false;
6518 155 : if (!kind_value_check (c, 1, gfc_default_character_kind))
6519 : return false;
6520 149 : if (strcmp (gfc_current_intrinsic, "fgetc") == 0
6521 149 : && !variable_check (c, 1, false))
6522 : return false;
6523 148 : if (arg_strlen_is_zero (c, 1))
6524 : return false;
6525 :
6526 147 : if (status == NULL)
6527 : return true;
6528 :
6529 58 : if (!type_check (status, 2, BT_INTEGER)
6530 58 : || !kind_value_check (status, 2, gfc_default_integer_kind)
6531 58 : || !scalar_check (status, 2)
6532 116 : || !variable_check (status, 2, false))
6533 2 : return false;
6534 :
6535 : return true;
6536 : }
6537 :
6538 :
6539 : bool
6540 71 : gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
6541 : {
6542 71 : return gfc_check_fgetputc_sub (unit, c, NULL);
6543 : }
6544 :
6545 :
6546 : bool
6547 17 : gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
6548 : {
6549 17 : if (!type_check (c, 0, BT_CHARACTER))
6550 : return false;
6551 17 : if (!kind_value_check (c, 0, gfc_default_character_kind))
6552 : return false;
6553 11 : if (strcmp (gfc_current_intrinsic, "fget") == 0
6554 11 : && !variable_check (c, 0, false))
6555 : return false;
6556 9 : if (arg_strlen_is_zero (c, 0))
6557 : return false;
6558 :
6559 8 : if (status == NULL)
6560 : return true;
6561 :
6562 2 : if (!type_check (status, 1, BT_INTEGER)
6563 2 : || !kind_value_check (status, 1, gfc_default_integer_kind)
6564 2 : || !scalar_check (status, 1)
6565 4 : || !variable_check (status, 1, false))
6566 0 : return false;
6567 :
6568 : return true;
6569 : }
6570 :
6571 :
6572 : bool
6573 8 : gfc_check_fgetput (gfc_expr *c)
6574 : {
6575 8 : return gfc_check_fgetput_sub (c, NULL);
6576 : }
6577 :
6578 :
6579 : bool
6580 60 : gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
6581 : {
6582 60 : if (!type_check (unit, 0, BT_INTEGER))
6583 : return false;
6584 :
6585 60 : if (!scalar_check (unit, 0))
6586 : return false;
6587 :
6588 60 : if (!type_check (offset, 1, BT_INTEGER))
6589 : return false;
6590 :
6591 60 : if (!scalar_check (offset, 1))
6592 : return false;
6593 :
6594 60 : if (!type_check (whence, 2, BT_INTEGER))
6595 : return false;
6596 :
6597 60 : if (!scalar_check (whence, 2))
6598 : return false;
6599 :
6600 60 : if (status == NULL)
6601 : return true;
6602 :
6603 54 : if (!type_check (status, 3, BT_INTEGER))
6604 : return false;
6605 :
6606 54 : if (!kind_value_check (status, 3, 4))
6607 : return false;
6608 :
6609 54 : if (!scalar_check (status, 3))
6610 : return false;
6611 :
6612 : return true;
6613 : }
6614 :
6615 :
6616 :
6617 : bool
6618 43 : gfc_check_fstat (gfc_expr *unit, gfc_expr *values)
6619 : {
6620 43 : if (!type_check (unit, 0, BT_INTEGER))
6621 : return false;
6622 :
6623 43 : if (!scalar_check (unit, 0))
6624 : return false;
6625 :
6626 43 : if (!type_check (values, 1, BT_INTEGER))
6627 : return false;
6628 :
6629 43 : if (values->ts.kind != 4 && values->ts.kind != 8)
6630 : {
6631 1 : error_unsupported_kind (values, 1);
6632 1 : return false;
6633 : }
6634 :
6635 42 : if (!array_check (values, 1))
6636 : return false;
6637 :
6638 42 : if (!variable_check (values, 1, false))
6639 : return false;
6640 :
6641 40 : if (!array_size_check (values, 1, 13))
6642 : return false;
6643 :
6644 : return true;
6645 : }
6646 :
6647 :
6648 : bool
6649 28 : gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *values, gfc_expr *status)
6650 : {
6651 28 : if (!gfc_check_fstat (unit, values))
6652 : return false;
6653 :
6654 25 : if (status == NULL)
6655 : return true;
6656 :
6657 19 : if (!type_check (status, 2, BT_INTEGER)
6658 19 : || !check_minrange4 (status, 2))
6659 1 : return false;
6660 :
6661 18 : if (!scalar_check (status, 2))
6662 : return false;
6663 :
6664 18 : if (!variable_check (status, 2, false))
6665 : return false;
6666 :
6667 : return true;
6668 : }
6669 :
6670 :
6671 : bool
6672 102 : gfc_check_ftell (gfc_expr *unit)
6673 : {
6674 102 : if (!type_check (unit, 0, BT_INTEGER))
6675 : return false;
6676 :
6677 102 : if (!scalar_check (unit, 0))
6678 : return false;
6679 :
6680 : return true;
6681 : }
6682 :
6683 :
6684 : bool
6685 36 : gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
6686 : {
6687 36 : if (!type_check (unit, 0, BT_INTEGER))
6688 : return false;
6689 :
6690 36 : if (!scalar_check (unit, 0))
6691 : return false;
6692 :
6693 36 : if (!type_check (offset, 1, BT_INTEGER))
6694 : return false;
6695 :
6696 36 : if (!scalar_check (offset, 1))
6697 : return false;
6698 :
6699 : return true;
6700 : }
6701 :
6702 :
6703 : bool
6704 86 : gfc_check_stat (gfc_expr *name, gfc_expr *values)
6705 : {
6706 86 : if (!type_check (name, 0, BT_CHARACTER))
6707 : return false;
6708 86 : if (!kind_value_check (name, 0, gfc_default_character_kind))
6709 : return false;
6710 :
6711 80 : if (!type_check (values, 1, BT_INTEGER))
6712 : return false;
6713 :
6714 80 : if (values->ts.kind != 4 && values->ts.kind != 8)
6715 : {
6716 1 : error_unsupported_kind (values, 1);
6717 1 : return false;
6718 : }
6719 :
6720 79 : if (!array_check (values, 1))
6721 : return false;
6722 :
6723 79 : if (!variable_check (values, 1, false))
6724 : return false;
6725 :
6726 75 : if (!array_size_check (values, 1, 13))
6727 : return false;
6728 :
6729 : return true;
6730 : }
6731 :
6732 :
6733 : bool
6734 53 : gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status)
6735 : {
6736 53 : if (!gfc_check_stat (name, values))
6737 : return false;
6738 :
6739 45 : if (status == NULL)
6740 : return true;
6741 :
6742 39 : if (!type_check (status, 2, BT_INTEGER)
6743 39 : || !check_minrange4 (status, 2))
6744 1 : return false;
6745 :
6746 38 : if (!scalar_check (status, 2))
6747 : return false;
6748 :
6749 38 : if (!variable_check (status, 2, false))
6750 : return false;
6751 :
6752 : return true;
6753 : }
6754 :
6755 :
6756 : bool
6757 288 : gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub,
6758 : gfc_expr *team_or_team_number)
6759 : {
6760 288 : mpz_t nelems;
6761 :
6762 288 : if (flag_coarray == GFC_FCOARRAY_NONE)
6763 : {
6764 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
6765 : gfc_current_intrinsic_where);
6766 : return false;
6767 : }
6768 :
6769 288 : if (!coarray_check (coarray, 0))
6770 : return false;
6771 :
6772 287 : if (sub->rank != 1)
6773 : {
6774 1 : gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
6775 1 : gfc_current_intrinsic_arg[1]->name, &sub->where);
6776 1 : return false;
6777 : }
6778 :
6779 286 : if (!type_check (sub, 1, BT_INTEGER))
6780 : return false;
6781 :
6782 285 : if (gfc_array_size (sub, &nelems))
6783 : {
6784 285 : if (mpz_cmp_ui (nelems, coarray->corank) != 0)
6785 : {
6786 3 : gfc_error ("The number of array elements of the SUB argument to "
6787 : "IMAGE_INDEX at %L shall be %d (corank) not %d",
6788 3 : &sub->where, coarray->corank, (int) mpz_get_si (nelems));
6789 3 : mpz_clear (nelems);
6790 3 : return false;
6791 : }
6792 282 : mpz_clear (nelems);
6793 : }
6794 :
6795 282 : if (team_or_team_number)
6796 : {
6797 0 : if (!type_check2 (team_or_team_number, 2, BT_DERIVED, BT_INTEGER)
6798 0 : || !scalar_check (team_or_team_number, 2))
6799 0 : return false;
6800 :
6801 : /* Check team is of team_type. */
6802 0 : if (team_or_team_number->ts.type == BT_DERIVED
6803 0 : && !team_type_check (team_or_team_number, 2))
6804 : return false;
6805 : }
6806 :
6807 : return true;
6808 : }
6809 :
6810 : bool
6811 1241 : gfc_check_num_images (gfc_expr *team_or_team_number)
6812 : {
6813 1241 : if (flag_coarray == GFC_FCOARRAY_NONE)
6814 : {
6815 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
6816 : gfc_current_intrinsic_where);
6817 : return false;
6818 : }
6819 :
6820 1241 : if (!team_or_team_number)
6821 : return true;
6822 :
6823 33 : if (!gfc_notify_std (GFC_STD_F2008,
6824 : "%<team%> or %<team_number%> argument to %qs at %L",
6825 : gfc_current_intrinsic, &team_or_team_number->where))
6826 : return false;
6827 :
6828 33 : if (!type_check2 (team_or_team_number, 0, BT_DERIVED, BT_INTEGER)
6829 33 : || !scalar_check (team_or_team_number, 0))
6830 1 : return false;
6831 :
6832 32 : if (team_or_team_number->ts.type == BT_DERIVED
6833 32 : && !team_type_check (team_or_team_number, 0))
6834 : return false;
6835 :
6836 : return true;
6837 : }
6838 :
6839 :
6840 : bool
6841 35 : gfc_check_team_number (gfc_expr *team)
6842 : {
6843 35 : if (flag_coarray == GFC_FCOARRAY_NONE)
6844 : {
6845 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
6846 : gfc_current_intrinsic_where);
6847 : return false;
6848 : }
6849 :
6850 35 : return !team || (scalar_check (team, 0) && team_type_check (team, 0));
6851 : }
6852 :
6853 :
6854 : bool
6855 2200 : gfc_check_this_image (gfc_actual_arglist *args)
6856 : {
6857 2200 : gfc_expr *coarray, *dim, *team, *cur;
6858 :
6859 2200 : coarray = dim = team = NULL;
6860 :
6861 2200 : if (flag_coarray == GFC_FCOARRAY_NONE)
6862 : {
6863 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
6864 : gfc_current_intrinsic_where);
6865 : return false;
6866 : }
6867 :
6868 : /* Shortcut when no arguments are given. */
6869 2200 : if (!args->expr && !args->next->expr && !args->next->next->expr)
6870 : return true;
6871 :
6872 636 : cur = args->expr;
6873 :
6874 636 : if (cur)
6875 : {
6876 635 : gfc_push_suppress_errors ();
6877 635 : if (coarray_check (cur, 0))
6878 : coarray = cur;
6879 15 : else if (scalar_check (cur, 2) && team_type_check (cur, 2))
6880 : team = cur;
6881 : else
6882 : {
6883 1 : gfc_pop_suppress_errors ();
6884 1 : gfc_error ("First argument of %<this_image%> intrinsic at %L must be "
6885 : "a coarray "
6886 : "variable or an object of type %<team_type%> from the "
6887 : "intrinsic module "
6888 : "%<ISO_FORTRAN_ENV%>",
6889 : &cur->where);
6890 1 : return false;
6891 : }
6892 634 : gfc_pop_suppress_errors ();
6893 : }
6894 :
6895 635 : cur = args->next->expr;
6896 635 : if (cur)
6897 : {
6898 490 : gfc_push_suppress_errors ();
6899 490 : if (dim_check (cur, 1, true) && cur->corank == 0)
6900 : dim = cur;
6901 18 : else if (scalar_check (cur, 2) && team_type_check (cur, 2))
6902 : {
6903 14 : if (team)
6904 : {
6905 0 : gfc_pop_suppress_errors ();
6906 0 : goto team_type_error;
6907 : }
6908 : team = cur;
6909 : }
6910 : else
6911 : {
6912 4 : gfc_pop_suppress_errors ();
6913 4 : gfc_error ("Second argument of %<this_image%> intrinsic at %L must "
6914 : "be an %<INTEGER%> "
6915 : "typed scalar or an object of type %<team_type%> from the "
6916 : "intrinsic "
6917 : "module %<ISO_FORTRAN_ENV%>",
6918 : &cur->where);
6919 4 : return false;
6920 : }
6921 486 : gfc_pop_suppress_errors ();
6922 : }
6923 :
6924 631 : cur = args->next->next->expr;
6925 631 : if (cur)
6926 : {
6927 15 : if (team_type_check (cur, 2) && scalar_check (cur, 2))
6928 : {
6929 14 : if (team)
6930 0 : goto team_type_error;
6931 : team = cur;
6932 : }
6933 : else
6934 1 : return false;
6935 : }
6936 :
6937 630 : if (dim != NULL && coarray == NULL)
6938 : {
6939 1 : gfc_error ("%<dim%> argument without %<coarray%> argument not allowed "
6940 : "for %<this_image%> intrinsic at %L",
6941 : &dim->where);
6942 1 : return false;
6943 : }
6944 :
6945 629 : if (dim && !dim_corank_check (dim, coarray))
6946 : return false;
6947 :
6948 628 : if (team
6949 628 : && !gfc_notify_std (GFC_STD_F2018,
6950 : "%<team%> argument to %<this_image%> at %L",
6951 : &team->where))
6952 : return false;
6953 :
6954 628 : args->expr = coarray;
6955 628 : args->next->expr = dim;
6956 628 : args->next->next->expr = team;
6957 628 : return true;
6958 :
6959 0 : team_type_error:
6960 0 : gfc_error (
6961 : "At most one argument of type %<team_type%> from the intrinsic module "
6962 : "%<ISO_FORTRAN_ENV%> to %<this_image%> at %L allowed",
6963 : &cur->where);
6964 0 : return false;
6965 : }
6966 :
6967 : /* Calculate the sizes for transfer, used by gfc_check_transfer and also
6968 : by gfc_simplify_transfer. Return false if we cannot do so. */
6969 :
6970 : bool
6971 945 : gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
6972 : size_t *source_size, size_t *result_size,
6973 : size_t *result_length_p)
6974 : {
6975 945 : size_t result_elt_size;
6976 :
6977 945 : if (source->expr_type == EXPR_FUNCTION)
6978 : return false;
6979 :
6980 944 : if (size && size->expr_type != EXPR_CONSTANT)
6981 : return false;
6982 :
6983 : /* Calculate the size of the source. */
6984 943 : if (!gfc_target_expr_size (source, source_size))
6985 : return false;
6986 :
6987 : /* Determine the size of the element. */
6988 942 : if (!gfc_element_size (mold, &result_elt_size))
6989 : return false;
6990 :
6991 : /* If the storage size of SOURCE is greater than zero and MOLD is an array,
6992 : * a scalar with the type and type parameters of MOLD shall not have a
6993 : * storage size equal to zero.
6994 : * If MOLD is a scalar and SIZE is absent, the result is a scalar.
6995 : * If MOLD is an array and SIZE is absent, the result is an array and of
6996 : * rank one. Its size is as small as possible such that its physical
6997 : * representation is not shorter than that of SOURCE.
6998 : * If SIZE is present, the result is an array of rank one and size SIZE.
6999 : */
7000 916 : if (result_elt_size == 0 && *source_size > 0
7001 14 : && (mold->expr_type == EXPR_ARRAY || mold->rank))
7002 : {
7003 8 : gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
7004 : "array and shall not have storage size 0 when %<SOURCE%> "
7005 : "argument has size greater than 0", &mold->where);
7006 8 : return false;
7007 : }
7008 :
7009 908 : if (result_elt_size == 0 && *source_size == 0 && !size)
7010 : {
7011 41 : *result_size = 0;
7012 41 : if (result_length_p)
7013 40 : *result_length_p = 0;
7014 41 : return true;
7015 : }
7016 :
7017 867 : if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank))
7018 672 : || size)
7019 : {
7020 195 : int result_length;
7021 :
7022 195 : if (size)
7023 167 : result_length = (size_t)mpz_get_ui (size->value.integer);
7024 : else
7025 : {
7026 132 : result_length = *source_size / result_elt_size;
7027 132 : if (result_length * result_elt_size < *source_size)
7028 0 : result_length += 1;
7029 : }
7030 :
7031 279 : *result_size = result_length * result_elt_size;
7032 279 : if (result_length_p)
7033 271 : *result_length_p = result_length;
7034 : }
7035 : else
7036 588 : *result_size = result_elt_size;
7037 :
7038 : return true;
7039 : }
7040 :
7041 :
7042 : bool
7043 2169 : gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
7044 : {
7045 2169 : size_t source_size;
7046 2169 : size_t result_size;
7047 :
7048 2169 : if (gfc_invalid_null_arg (source))
7049 : return false;
7050 :
7051 : /* SOURCE shall be a scalar or array of any type. */
7052 2166 : if (source->ts.type == BT_PROCEDURE
7053 3 : && source->symtree->n.sym->attr.subroutine == 1)
7054 : {
7055 1 : gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
7056 : "must not be a %s", &source->where,
7057 : gfc_basic_typename (source->ts.type));
7058 1 : return false;
7059 : }
7060 :
7061 2165 : if (source->ts.type == BT_BOZ && illegal_boz_arg (source))
7062 : return false;
7063 :
7064 2164 : if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold))
7065 : return false;
7066 :
7067 2163 : if (gfc_invalid_null_arg (mold))
7068 : return false;
7069 :
7070 : /* MOLD shall be a scalar or array of any type. */
7071 2161 : if (mold->ts.type == BT_PROCEDURE
7072 2 : && mold->symtree->n.sym->attr.subroutine == 1)
7073 : {
7074 1 : gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
7075 : "must not be a %s", &mold->where,
7076 : gfc_basic_typename (mold->ts.type));
7077 1 : return false;
7078 : }
7079 :
7080 2160 : if (mold->ts.type == BT_HOLLERITH)
7081 : {
7082 1 : gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
7083 : " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
7084 1 : return false;
7085 : }
7086 :
7087 : /* SIZE (optional) shall be an integer scalar. The corresponding actual
7088 : argument shall not be an optional dummy argument. */
7089 2159 : if (size != NULL)
7090 : {
7091 368 : if (!type_check (size, 2, BT_INTEGER))
7092 : {
7093 1 : if (size->ts.type == BT_BOZ)
7094 1 : reset_boz (size);
7095 1 : return false;
7096 : }
7097 :
7098 367 : if (!scalar_check (size, 2))
7099 : return false;
7100 :
7101 367 : if (!nonoptional_check (size, 2))
7102 : return false;
7103 : }
7104 :
7105 2158 : if (!warn_surprising)
7106 : return true;
7107 :
7108 : /* If we can't calculate the sizes, we cannot check any more.
7109 : Return true for that case. */
7110 :
7111 52 : if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
7112 : &result_size, NULL))
7113 : return true;
7114 :
7115 49 : if (source_size < result_size)
7116 6 : gfc_warning (OPT_Wsurprising,
7117 : "Intrinsic TRANSFER at %L has partly undefined result: "
7118 : "source size %zd < result size %zd", &source->where,
7119 : source_size, result_size);
7120 :
7121 : return true;
7122 : }
7123 :
7124 :
7125 : bool
7126 1175 : gfc_check_transpose (gfc_expr *matrix)
7127 : {
7128 1175 : if (!rank_check (matrix, 0, 2))
7129 : return false;
7130 :
7131 : return true;
7132 : }
7133 :
7134 :
7135 : bool
7136 7172 : gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
7137 : {
7138 7172 : if (!array_check (array, 0))
7139 : return false;
7140 :
7141 7171 : if (!dim_check (dim, 1, false))
7142 : return false;
7143 :
7144 7171 : if (!dim_rank_check (dim, array, 0))
7145 : return false;
7146 :
7147 7169 : if (!kind_check (kind, 2, BT_INTEGER))
7148 : return false;
7149 7169 : if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
7150 : "with KIND argument at %L",
7151 : gfc_current_intrinsic, &kind->where))
7152 : return false;
7153 :
7154 : return true;
7155 : }
7156 :
7157 :
7158 : bool
7159 344 : gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
7160 : {
7161 344 : if (flag_coarray == GFC_FCOARRAY_NONE)
7162 : {
7163 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
7164 : gfc_current_intrinsic_where);
7165 : return false;
7166 : }
7167 :
7168 344 : if (!coarray_check (coarray, 0))
7169 : return false;
7170 :
7171 340 : if (dim != NULL)
7172 : {
7173 224 : if (!dim_check (dim, 1, false))
7174 : return false;
7175 :
7176 224 : if (!dim_corank_check (dim, coarray))
7177 : return false;
7178 : }
7179 :
7180 340 : if (!kind_check (kind, 2, BT_INTEGER))
7181 : return false;
7182 :
7183 : return true;
7184 : }
7185 :
7186 :
7187 : bool
7188 393 : gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
7189 : {
7190 393 : mpz_t vector_size;
7191 :
7192 393 : if (!rank_check (vector, 0, 1))
7193 : return false;
7194 :
7195 393 : if (!array_check (mask, 1))
7196 : return false;
7197 :
7198 393 : if (!type_check (mask, 1, BT_LOGICAL))
7199 : return false;
7200 :
7201 393 : if (!same_type_check (vector, 0, field, 2))
7202 : return false;
7203 :
7204 393 : gfc_simplify_expr (mask, 0);
7205 :
7206 393 : if (mask->expr_type == EXPR_ARRAY
7207 393 : && gfc_array_size (vector, &vector_size))
7208 : {
7209 40 : int mask_true_count = 0;
7210 40 : gfc_constructor *mask_ctor;
7211 40 : mask_ctor = gfc_constructor_first (mask->value.constructor);
7212 263 : while (mask_ctor)
7213 : {
7214 183 : if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
7215 : {
7216 : mask_true_count = 0;
7217 : break;
7218 : }
7219 :
7220 183 : if (mask_ctor->expr->value.logical)
7221 78 : mask_true_count++;
7222 :
7223 183 : mask_ctor = gfc_constructor_next (mask_ctor);
7224 : }
7225 :
7226 40 : if (mpz_get_si (vector_size) < mask_true_count)
7227 : {
7228 1 : gfc_error ("%qs argument of %qs intrinsic at %L must "
7229 : "provide at least as many elements as there "
7230 : "are .TRUE. values in %qs (%ld/%d)",
7231 1 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
7232 1 : &vector->where, gfc_current_intrinsic_arg[1]->name,
7233 : mpz_get_si (vector_size), mask_true_count);
7234 1 : return false;
7235 : }
7236 :
7237 39 : mpz_clear (vector_size);
7238 : }
7239 :
7240 392 : if (mask->rank != field->rank && field->rank != 0)
7241 : {
7242 0 : gfc_error ("%qs argument of %qs intrinsic at %L must have "
7243 : "the same rank as %qs or be a scalar",
7244 0 : gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
7245 0 : &field->where, gfc_current_intrinsic_arg[1]->name);
7246 0 : return false;
7247 : }
7248 :
7249 392 : if (mask->rank == field->rank)
7250 : {
7251 : int i;
7252 712 : for (i = 0; i < field->rank; i++)
7253 452 : if (! identical_dimen_shape (mask, i, field, i))
7254 : {
7255 5 : gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
7256 : "must have identical shape.",
7257 5 : gfc_current_intrinsic_arg[2]->name,
7258 5 : gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
7259 : &field->where);
7260 : }
7261 : }
7262 :
7263 : return true;
7264 : }
7265 :
7266 :
7267 : bool
7268 250 : gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
7269 : {
7270 250 : if (!type_check (x, 0, BT_CHARACTER))
7271 : return false;
7272 :
7273 250 : if (!same_type_check (x, 0, y, 1))
7274 : return false;
7275 :
7276 250 : if (z != NULL && !type_check (z, 2, BT_LOGICAL))
7277 : return false;
7278 :
7279 250 : if (!kind_check (kind, 3, BT_INTEGER))
7280 : return false;
7281 250 : if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
7282 : "with KIND argument at %L",
7283 : gfc_current_intrinsic, &kind->where))
7284 : return false;
7285 :
7286 : return true;
7287 : }
7288 :
7289 :
7290 : bool
7291 2076 : gfc_check_trim (gfc_expr *x)
7292 : {
7293 2076 : if (!type_check (x, 0, BT_CHARACTER))
7294 : return false;
7295 :
7296 2076 : if (gfc_invalid_null_arg (x))
7297 : return false;
7298 :
7299 2075 : if (!scalar_check (x, 0))
7300 : return false;
7301 :
7302 : return true;
7303 : }
7304 :
7305 :
7306 : bool
7307 0 : gfc_check_ttynam (gfc_expr *unit)
7308 : {
7309 0 : if (!scalar_check (unit, 0))
7310 : return false;
7311 :
7312 0 : if (!type_check (unit, 0, BT_INTEGER))
7313 : return false;
7314 :
7315 : return true;
7316 : }
7317 :
7318 :
7319 : /************* Check functions for intrinsic subroutines *************/
7320 :
7321 : bool
7322 21 : gfc_check_cpu_time (gfc_expr *time)
7323 : {
7324 21 : if (!scalar_check (time, 0))
7325 : return false;
7326 :
7327 21 : if (!type_check (time, 0, BT_REAL))
7328 : return false;
7329 :
7330 21 : if (!variable_check (time, 0, false))
7331 : return false;
7332 :
7333 : return true;
7334 : }
7335 :
7336 :
7337 : bool
7338 183 : gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
7339 : gfc_expr *zone, gfc_expr *values)
7340 : {
7341 183 : if (date != NULL)
7342 : {
7343 71 : if (!type_check (date, 0, BT_CHARACTER))
7344 : return false;
7345 71 : if (!kind_value_check (date, 0, gfc_default_character_kind))
7346 : return false;
7347 69 : if (!scalar_check (date, 0))
7348 : return false;
7349 69 : if (!variable_check (date, 0, false))
7350 : return false;
7351 : }
7352 :
7353 181 : if (time != NULL)
7354 : {
7355 79 : if (!type_check (time, 1, BT_CHARACTER))
7356 : return false;
7357 79 : if (!kind_value_check (time, 1, gfc_default_character_kind))
7358 : return false;
7359 78 : if (!scalar_check (time, 1))
7360 : return false;
7361 78 : if (!variable_check (time, 1, false))
7362 : return false;
7363 : }
7364 :
7365 180 : if (zone != NULL)
7366 : {
7367 70 : if (!type_check (zone, 2, BT_CHARACTER))
7368 : return false;
7369 70 : if (!kind_value_check (zone, 2, gfc_default_character_kind))
7370 : return false;
7371 69 : if (!scalar_check (zone, 2))
7372 : return false;
7373 69 : if (!variable_check (zone, 2, false))
7374 : return false;
7375 : }
7376 :
7377 179 : if (values != NULL)
7378 : {
7379 100 : if (!type_check (values, 3, BT_INTEGER))
7380 : return false;
7381 100 : if (!array_check (values, 3))
7382 : return false;
7383 100 : if (!rank_check (values, 3, 1))
7384 : return false;
7385 100 : if (!variable_check (values, 3, false))
7386 : return false;
7387 100 : if (!array_size_check (values, 3, 8))
7388 : return false;
7389 :
7390 99 : if (values->ts.kind != gfc_default_integer_kind
7391 99 : && !gfc_notify_std (GFC_STD_F2018, "VALUES argument of "
7392 : "DATE_AND_TIME at %L has non-default kind",
7393 : &values->where))
7394 : return false;
7395 :
7396 : /* F2018:16.9.59 DATE_AND_TIME
7397 : "VALUES shall be a rank-one array of type integer
7398 : with a decimal exponent range of at least four."
7399 : This is a hard limit also required by the implementation in
7400 : libgfortran. */
7401 99 : if (values->ts.kind < 2)
7402 : {
7403 1 : gfc_error ("VALUES argument of DATE_AND_TIME at %L must have "
7404 : "a decimal exponent range of at least four",
7405 : &values->where);
7406 1 : return false;
7407 : }
7408 : }
7409 :
7410 : return true;
7411 : }
7412 :
7413 :
7414 : bool
7415 203 : gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
7416 : gfc_expr *to, gfc_expr *topos)
7417 : {
7418 :
7419 203 : if (flag_unsigned)
7420 : {
7421 24 : if (!type_check2 (from, 0, BT_INTEGER, BT_UNSIGNED))
7422 : return false;
7423 : }
7424 : else
7425 : {
7426 179 : if (!type_check (from, 0, BT_INTEGER))
7427 : return false;
7428 : }
7429 :
7430 203 : if (!type_check (frompos, 1, BT_INTEGER))
7431 : return false;
7432 :
7433 203 : if (!type_check (len, 2, BT_INTEGER))
7434 : return false;
7435 :
7436 203 : if (!same_type_check (from, 0, to, 3))
7437 : return false;
7438 :
7439 203 : if (!variable_check (to, 3, false))
7440 : return false;
7441 :
7442 203 : if (!type_check (topos, 4, BT_INTEGER))
7443 : return false;
7444 :
7445 203 : if (!nonnegative_check ("frompos", frompos))
7446 : return false;
7447 :
7448 202 : if (!nonnegative_check ("topos", topos))
7449 : return false;
7450 :
7451 201 : if (!nonnegative_check ("len", len))
7452 : return false;
7453 :
7454 200 : if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len))
7455 : return false;
7456 :
7457 199 : if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len))
7458 : return false;
7459 :
7460 : return true;
7461 : }
7462 :
7463 :
7464 : /* Check the arguments for RANDOM_INIT. */
7465 :
7466 : bool
7467 94 : gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
7468 : {
7469 94 : if (!type_check (repeatable, 0, BT_LOGICAL))
7470 : return false;
7471 :
7472 93 : if (!scalar_check (repeatable, 0))
7473 : return false;
7474 :
7475 92 : if (!type_check (image_distinct, 1, BT_LOGICAL))
7476 : return false;
7477 :
7478 91 : if (!scalar_check (image_distinct, 1))
7479 : return false;
7480 :
7481 : return true;
7482 : }
7483 :
7484 :
7485 : bool
7486 530 : gfc_check_random_number (gfc_expr *harvest)
7487 : {
7488 530 : if (flag_unsigned)
7489 : {
7490 78 : if (!type_check2 (harvest, 0, BT_REAL, BT_UNSIGNED))
7491 : return false;
7492 : }
7493 : else
7494 452 : if (!type_check (harvest, 0, BT_REAL))
7495 : return false;
7496 :
7497 530 : if (!variable_check (harvest, 0, false))
7498 : return false;
7499 :
7500 : return true;
7501 : }
7502 :
7503 :
7504 : bool
7505 304 : gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
7506 : {
7507 304 : unsigned int nargs = 0, seed_size;
7508 304 : locus *where = NULL;
7509 304 : mpz_t put_size, get_size;
7510 :
7511 : /* Keep the number of bytes in sync with master_state in
7512 : libgfortran/intrinsics/random.c. */
7513 304 : seed_size = 32 / gfc_default_integer_kind;
7514 :
7515 304 : if (size != NULL)
7516 : {
7517 90 : if (size->expr_type != EXPR_VARIABLE
7518 90 : || !size->symtree->n.sym->attr.optional)
7519 68 : nargs++;
7520 :
7521 90 : if (!scalar_check (size, 0))
7522 : return false;
7523 :
7524 90 : if (!type_check (size, 0, BT_INTEGER))
7525 : return false;
7526 :
7527 90 : if (!variable_check (size, 0, false))
7528 : return false;
7529 :
7530 89 : if (!kind_value_check (size, 0, gfc_default_integer_kind))
7531 : return false;
7532 : }
7533 :
7534 303 : if (put != NULL)
7535 : {
7536 117 : if (put->expr_type != EXPR_VARIABLE
7537 117 : || !put->symtree->n.sym->attr.optional)
7538 : {
7539 96 : nargs++;
7540 96 : where = &put->where;
7541 : }
7542 :
7543 117 : if (!array_check (put, 1))
7544 : return false;
7545 :
7546 117 : if (!rank_check (put, 1, 1))
7547 : return false;
7548 :
7549 117 : if (!type_check (put, 1, BT_INTEGER))
7550 : return false;
7551 :
7552 117 : if (!kind_value_check (put, 1, gfc_default_integer_kind))
7553 : return false;
7554 :
7555 117 : if (gfc_array_size (put, &put_size))
7556 : {
7557 5 : if (mpz_get_ui (put_size) < seed_size)
7558 3 : gfc_error ("Size of %qs argument of %qs intrinsic at %L "
7559 : "too small (%i/%i)",
7560 3 : gfc_current_intrinsic_arg[1]->name,
7561 : gfc_current_intrinsic,
7562 3 : &put->where, (int) mpz_get_ui (put_size), seed_size);
7563 5 : mpz_clear (put_size);
7564 : }
7565 : }
7566 :
7567 303 : if (get != NULL)
7568 : {
7569 136 : if (get->expr_type != EXPR_VARIABLE
7570 136 : || !get->symtree->n.sym->attr.optional)
7571 : {
7572 115 : nargs++;
7573 115 : where = &get->where;
7574 : }
7575 :
7576 136 : if (!array_check (get, 2))
7577 : return false;
7578 :
7579 136 : if (!rank_check (get, 2, 1))
7580 : return false;
7581 :
7582 136 : if (!type_check (get, 2, BT_INTEGER))
7583 : return false;
7584 :
7585 136 : if (!variable_check (get, 2, false))
7586 : return false;
7587 :
7588 136 : if (!kind_value_check (get, 2, gfc_default_integer_kind))
7589 : return false;
7590 :
7591 136 : if (gfc_array_size (get, &get_size))
7592 : {
7593 5 : if (mpz_get_ui (get_size) < seed_size)
7594 3 : gfc_error ("Size of %qs argument of %qs intrinsic at %L "
7595 : "too small (%i/%i)",
7596 3 : gfc_current_intrinsic_arg[2]->name,
7597 : gfc_current_intrinsic,
7598 3 : &get->where, (int) mpz_get_ui (get_size), seed_size);
7599 5 : mpz_clear (get_size);
7600 : }
7601 : }
7602 :
7603 : /* RANDOM_SEED may not have more than one non-optional argument. */
7604 303 : if (nargs > 1)
7605 1 : gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
7606 :
7607 : return true;
7608 : }
7609 :
7610 : bool
7611 391 : gfc_check_fe_runtime_error (gfc_actual_arglist *a)
7612 : {
7613 391 : gfc_expr *e;
7614 391 : size_t len, i;
7615 391 : int num_percent, nargs;
7616 :
7617 391 : e = a->expr;
7618 391 : if (e->expr_type != EXPR_CONSTANT)
7619 : return true;
7620 :
7621 391 : len = e->value.character.length;
7622 391 : if (e->value.character.string[len-1] != '\0')
7623 0 : gfc_internal_error ("fe_runtime_error string must be null terminated");
7624 :
7625 : num_percent = 0;
7626 27011 : for (i=0; i<len-1; i++)
7627 26620 : if (e->value.character.string[i] == '%')
7628 782 : num_percent ++;
7629 :
7630 : nargs = 0;
7631 1564 : for (; a; a = a->next)
7632 1173 : nargs ++;
7633 :
7634 391 : if (nargs -1 != num_percent)
7635 0 : gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
7636 : nargs, num_percent++);
7637 :
7638 : return true;
7639 : }
7640 :
7641 : bool
7642 0 : gfc_check_second_sub (gfc_expr *time)
7643 : {
7644 0 : if (!scalar_check (time, 0))
7645 : return false;
7646 :
7647 0 : if (!type_check (time, 0, BT_REAL))
7648 : return false;
7649 :
7650 0 : if (!kind_value_check (time, 0, 4))
7651 : return false;
7652 :
7653 : return true;
7654 : }
7655 :
7656 :
7657 : /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
7658 : variables in Fortran 95. In Fortran 2003 and later, they can be of any
7659 : kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
7660 : count_max are all optional arguments */
7661 :
7662 : bool
7663 212 : gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
7664 : gfc_expr *count_max)
7665 : {
7666 212 : int first_int_kind = -1;
7667 :
7668 212 : if (count != NULL)
7669 : {
7670 207 : if (!scalar_check (count, 0))
7671 : return false;
7672 :
7673 207 : if (!type_check (count, 0, BT_INTEGER))
7674 : return false;
7675 :
7676 207 : if (count->ts.kind != gfc_default_integer_kind
7677 207 : && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
7678 : "SYSTEM_CLOCK at %L has non-default kind",
7679 : &count->where))
7680 : return false;
7681 :
7682 206 : if (count->ts.kind < gfc_default_integer_kind
7683 206 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7684 : "COUNT argument to SYSTEM_CLOCK at %L "
7685 : "with kind smaller than default integer",
7686 : &count->where))
7687 : return false;
7688 :
7689 205 : if (!variable_check (count, 0, false))
7690 : return false;
7691 :
7692 205 : first_int_kind = count->ts.kind;
7693 : }
7694 :
7695 210 : if (count_rate != NULL)
7696 : {
7697 194 : if (!scalar_check (count_rate, 1))
7698 : return false;
7699 :
7700 194 : if (!variable_check (count_rate, 1, false))
7701 : return false;
7702 :
7703 194 : if (count_rate->ts.type == BT_REAL)
7704 : {
7705 120 : if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
7706 : "SYSTEM_CLOCK at %L", &count_rate->where))
7707 : return false;
7708 : }
7709 : else
7710 : {
7711 74 : if (!type_check (count_rate, 1, BT_INTEGER))
7712 : return false;
7713 :
7714 74 : if (count_rate->ts.kind != gfc_default_integer_kind
7715 74 : && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
7716 : "SYSTEM_CLOCK at %L has non-default kind",
7717 : &count_rate->where))
7718 : return false;
7719 :
7720 73 : if (count_rate->ts.kind < gfc_default_integer_kind
7721 73 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7722 : "COUNT_RATE argument to SYSTEM_CLOCK at %L "
7723 : "with kind smaller than default integer",
7724 : &count_rate->where))
7725 : return false;
7726 :
7727 72 : if (first_int_kind < 0)
7728 2 : first_int_kind = count_rate->ts.kind;
7729 : }
7730 :
7731 : }
7732 :
7733 206 : if (count_max != NULL)
7734 : {
7735 189 : if (!scalar_check (count_max, 2))
7736 : return false;
7737 :
7738 189 : if (!type_check (count_max, 2, BT_INTEGER))
7739 : return false;
7740 :
7741 189 : if (count_max->ts.kind != gfc_default_integer_kind
7742 189 : && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
7743 : "SYSTEM_CLOCK at %L has non-default kind",
7744 : &count_max->where))
7745 : return false;
7746 :
7747 188 : if (!variable_check (count_max, 2, false))
7748 : return false;
7749 :
7750 188 : if (count_max->ts.kind < gfc_default_integer_kind
7751 188 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7752 : "COUNT_MAX argument to SYSTEM_CLOCK at %L "
7753 : "with kind smaller than default integer",
7754 : &count_max->where))
7755 : return false;
7756 :
7757 187 : if (first_int_kind < 0)
7758 0 : first_int_kind = count_max->ts.kind;
7759 : }
7760 :
7761 204 : if (first_int_kind > 0)
7762 : {
7763 203 : if (count_rate
7764 188 : && count_rate->ts.type == BT_INTEGER
7765 71 : && count_rate->ts.kind != first_int_kind
7766 235 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7767 : "integer arguments to SYSTEM_CLOCK at %L "
7768 : "with different kind parameters",
7769 : &count_rate->where))
7770 : return false;
7771 :
7772 187 : if (count_max && count_max->ts.kind != first_int_kind
7773 284 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7774 : "integer arguments to SYSTEM_CLOCK at %L "
7775 : "with different kind parameters",
7776 : &count_max->where))
7777 : return false;
7778 : }
7779 :
7780 : return true;
7781 : }
7782 :
7783 :
7784 : bool
7785 2 : gfc_check_irand (gfc_expr *x)
7786 : {
7787 2 : if (x == NULL)
7788 : return true;
7789 :
7790 0 : if (!scalar_check (x, 0))
7791 : return false;
7792 :
7793 0 : if (!type_check (x, 0, BT_INTEGER))
7794 : return false;
7795 :
7796 0 : if (!kind_value_check (x, 0, 4))
7797 : return false;
7798 :
7799 : return true;
7800 : }
7801 :
7802 :
7803 : bool
7804 0 : gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
7805 : {
7806 0 : if (!scalar_check (seconds, 0))
7807 : return false;
7808 0 : if (!type_check (seconds, 0, BT_INTEGER))
7809 : return false;
7810 :
7811 0 : if (!int_or_proc_check (handler, 1))
7812 : return false;
7813 0 : if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
7814 : return false;
7815 :
7816 0 : if (status == NULL)
7817 : return true;
7818 :
7819 0 : if (!scalar_check (status, 2))
7820 : return false;
7821 0 : if (!type_check (status, 2, BT_INTEGER))
7822 : return false;
7823 0 : if (!kind_value_check (status, 2, gfc_default_integer_kind))
7824 : return false;
7825 :
7826 : return true;
7827 : }
7828 :
7829 :
7830 : bool
7831 34 : gfc_check_rand (gfc_expr *x)
7832 : {
7833 34 : if (x == NULL)
7834 : return true;
7835 :
7836 1 : if (!scalar_check (x, 0))
7837 : return false;
7838 :
7839 1 : if (!type_check (x, 0, BT_INTEGER))
7840 : return false;
7841 :
7842 1 : if (!kind_value_check (x, 0, 4))
7843 : return false;
7844 :
7845 : return true;
7846 : }
7847 :
7848 :
7849 : bool
7850 0 : gfc_check_srand (gfc_expr *x)
7851 : {
7852 0 : if (!scalar_check (x, 0))
7853 : return false;
7854 :
7855 0 : if (!type_check (x, 0, BT_INTEGER))
7856 : return false;
7857 :
7858 0 : if (!kind_value_check (x, 0, 4))
7859 : return false;
7860 :
7861 : return true;
7862 : }
7863 :
7864 :
7865 : bool
7866 2 : gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
7867 : {
7868 2 : if (!scalar_check (time, 0))
7869 : return false;
7870 2 : if (!type_check (time, 0, BT_INTEGER))
7871 : return false;
7872 :
7873 2 : if (!type_check (result, 1, BT_CHARACTER))
7874 : return false;
7875 2 : if (!kind_value_check (result, 1, gfc_default_character_kind))
7876 : return false;
7877 :
7878 : return true;
7879 : }
7880 :
7881 :
7882 : bool
7883 1 : gfc_check_dtime_etime (gfc_expr *x)
7884 : {
7885 1 : if (!array_check (x, 0))
7886 : return false;
7887 :
7888 1 : if (!rank_check (x, 0, 1))
7889 : return false;
7890 :
7891 1 : if (!variable_check (x, 0, false))
7892 : return false;
7893 :
7894 1 : if (!type_check (x, 0, BT_REAL))
7895 : return false;
7896 :
7897 1 : if (!kind_value_check (x, 0, 4))
7898 : return false;
7899 :
7900 : return true;
7901 : }
7902 :
7903 :
7904 : bool
7905 1 : gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
7906 : {
7907 1 : if (!array_check (values, 0))
7908 : return false;
7909 :
7910 1 : if (!rank_check (values, 0, 1))
7911 : return false;
7912 :
7913 1 : if (!variable_check (values, 0, false))
7914 : return false;
7915 :
7916 1 : if (!type_check (values, 0, BT_REAL))
7917 : return false;
7918 :
7919 1 : if (!kind_value_check (values, 0, 4))
7920 : return false;
7921 :
7922 1 : if (!scalar_check (time, 1))
7923 : return false;
7924 :
7925 1 : if (!type_check (time, 1, BT_REAL))
7926 : return false;
7927 :
7928 1 : if (!kind_value_check (time, 1, 4))
7929 : return false;
7930 :
7931 : return true;
7932 : }
7933 :
7934 :
7935 : bool
7936 2 : gfc_check_fdate_sub (gfc_expr *date)
7937 : {
7938 2 : if (!type_check (date, 0, BT_CHARACTER))
7939 : return false;
7940 2 : if (!kind_value_check (date, 0, gfc_default_character_kind))
7941 : return false;
7942 :
7943 : return true;
7944 : }
7945 :
7946 :
7947 : bool
7948 3 : gfc_check_gerror (gfc_expr *msg)
7949 : {
7950 3 : if (!type_check (msg, 0, BT_CHARACTER))
7951 : return false;
7952 3 : if (!kind_value_check (msg, 0, gfc_default_character_kind))
7953 : return false;
7954 :
7955 : return true;
7956 : }
7957 :
7958 :
7959 : bool
7960 10 : gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
7961 : {
7962 10 : if (!type_check (cwd, 0, BT_CHARACTER))
7963 : return false;
7964 10 : if (!kind_value_check (cwd, 0, gfc_default_character_kind))
7965 : return false;
7966 :
7967 8 : if (status == NULL)
7968 : return true;
7969 :
7970 1 : if (!scalar_check (status, 1))
7971 : return false;
7972 :
7973 1 : if (!type_check (status, 1, BT_INTEGER))
7974 : return false;
7975 :
7976 : return true;
7977 : }
7978 :
7979 :
7980 : bool
7981 56 : gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
7982 : {
7983 56 : if (!type_check (pos, 0, BT_INTEGER))
7984 : return false;
7985 :
7986 56 : if (pos->ts.kind > gfc_default_integer_kind)
7987 : {
7988 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
7989 : "not wider than the default kind (%d)",
7990 0 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
7991 : &pos->where, gfc_default_integer_kind);
7992 0 : return false;
7993 : }
7994 :
7995 56 : if (!type_check (value, 1, BT_CHARACTER))
7996 : return false;
7997 56 : if (!kind_value_check (value, 1, gfc_default_character_kind))
7998 : return false;
7999 :
8000 : return true;
8001 : }
8002 :
8003 :
8004 : bool
8005 3 : gfc_check_getlog (gfc_expr *msg)
8006 : {
8007 3 : if (!type_check (msg, 0, BT_CHARACTER))
8008 : return false;
8009 3 : if (!kind_value_check (msg, 0, gfc_default_character_kind))
8010 : return false;
8011 :
8012 : return true;
8013 : }
8014 :
8015 :
8016 : bool
8017 3 : gfc_check_exit (gfc_expr *status)
8018 : {
8019 3 : if (status == NULL)
8020 : return true;
8021 :
8022 2 : if (!type_check (status, 0, BT_INTEGER))
8023 : return false;
8024 :
8025 2 : if (!scalar_check (status, 0))
8026 : return false;
8027 :
8028 : return true;
8029 : }
8030 :
8031 :
8032 : bool
8033 25 : gfc_check_flush (gfc_expr *unit)
8034 : {
8035 25 : if (unit == NULL)
8036 : return true;
8037 :
8038 12 : if (!type_check (unit, 0, BT_INTEGER))
8039 : return false;
8040 :
8041 12 : if (!scalar_check (unit, 0))
8042 : return false;
8043 :
8044 : return true;
8045 : }
8046 :
8047 :
8048 : bool
8049 10 : gfc_check_free (gfc_expr *i)
8050 : {
8051 10 : if (!type_check (i, 0, BT_INTEGER))
8052 : return false;
8053 :
8054 10 : if (!scalar_check (i, 0))
8055 : return false;
8056 :
8057 : return true;
8058 : }
8059 :
8060 :
8061 : bool
8062 5 : gfc_check_hostnm (gfc_expr *name)
8063 : {
8064 5 : if (!type_check (name, 0, BT_CHARACTER))
8065 : return false;
8066 5 : if (!kind_value_check (name, 0, gfc_default_character_kind))
8067 : return false;
8068 :
8069 : return true;
8070 : }
8071 :
8072 :
8073 : bool
8074 11 : gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
8075 : {
8076 11 : if (!type_check (name, 0, BT_CHARACTER))
8077 : return false;
8078 11 : if (!kind_value_check (name, 0, gfc_default_character_kind))
8079 : return false;
8080 :
8081 9 : if (status == NULL)
8082 : return true;
8083 :
8084 7 : if (!scalar_check (status, 1))
8085 : return false;
8086 :
8087 7 : if (!type_check (status, 1, BT_INTEGER))
8088 : return false;
8089 :
8090 : return true;
8091 : }
8092 :
8093 :
8094 : bool
8095 24 : gfc_check_itime_idate (gfc_expr *values)
8096 : {
8097 24 : if (!array_check (values, 0))
8098 : return false;
8099 :
8100 24 : if (!rank_check (values, 0, 1))
8101 : return false;
8102 :
8103 24 : if (!variable_check (values, 0, false))
8104 : return false;
8105 :
8106 24 : if (!type_check (values, 0, BT_INTEGER))
8107 : return false;
8108 :
8109 24 : if (!kind_value_check (values, 0, gfc_default_integer_kind))
8110 : return false;
8111 :
8112 : return true;
8113 : }
8114 :
8115 :
8116 : bool
8117 24 : gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
8118 : {
8119 24 : if (!type_check (time, 0, BT_INTEGER))
8120 : return false;
8121 :
8122 24 : if (!kind_value_check (time, 0, gfc_default_integer_kind))
8123 : return false;
8124 :
8125 24 : if (!scalar_check (time, 0))
8126 : return false;
8127 :
8128 24 : if (!array_check (values, 1))
8129 : return false;
8130 :
8131 24 : if (!rank_check (values, 1, 1))
8132 : return false;
8133 :
8134 24 : if (!variable_check (values, 1, false))
8135 : return false;
8136 :
8137 24 : if (!type_check (values, 1, BT_INTEGER))
8138 : return false;
8139 :
8140 24 : if (!kind_value_check (values, 1, gfc_default_integer_kind))
8141 : return false;
8142 :
8143 : return true;
8144 : }
8145 :
8146 :
8147 : bool
8148 2 : gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
8149 : {
8150 2 : if (!scalar_check (unit, 0))
8151 : return false;
8152 :
8153 2 : if (!type_check (unit, 0, BT_INTEGER))
8154 : return false;
8155 :
8156 2 : if (!type_check (name, 1, BT_CHARACTER))
8157 : return false;
8158 2 : if (!kind_value_check (name, 1, gfc_default_character_kind))
8159 : return false;
8160 :
8161 : return true;
8162 : }
8163 :
8164 :
8165 : bool
8166 836 : gfc_check_is_contiguous (gfc_expr *array)
8167 : {
8168 836 : if (array->expr_type == EXPR_NULL)
8169 : {
8170 2 : gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
8171 : "associated pointer", &array->where, gfc_current_intrinsic);
8172 2 : return false;
8173 : }
8174 :
8175 834 : if (!array_check (array, 0))
8176 : return false;
8177 :
8178 : return true;
8179 : }
8180 :
8181 :
8182 : bool
8183 0 : gfc_check_isatty (gfc_expr *unit)
8184 : {
8185 0 : if (unit == NULL)
8186 : return false;
8187 :
8188 0 : if (!type_check (unit, 0, BT_INTEGER))
8189 : return false;
8190 :
8191 0 : if (!scalar_check (unit, 0))
8192 : return false;
8193 :
8194 : return true;
8195 : }
8196 :
8197 :
8198 : bool
8199 626 : gfc_check_isnan (gfc_expr *x)
8200 : {
8201 626 : if (!type_check (x, 0, BT_REAL))
8202 : return false;
8203 :
8204 : return true;
8205 : }
8206 :
8207 :
8208 : bool
8209 3 : gfc_check_perror (gfc_expr *string)
8210 : {
8211 3 : if (!type_check (string, 0, BT_CHARACTER))
8212 : return false;
8213 3 : if (!kind_value_check (string, 0, gfc_default_character_kind))
8214 : return false;
8215 :
8216 : return true;
8217 : }
8218 :
8219 :
8220 : bool
8221 0 : gfc_check_umask (gfc_expr *mask)
8222 : {
8223 0 : if (!type_check (mask, 0, BT_INTEGER))
8224 : return false;
8225 :
8226 0 : if (!scalar_check (mask, 0))
8227 : return false;
8228 :
8229 : return true;
8230 : }
8231 :
8232 :
8233 : bool
8234 0 : gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
8235 : {
8236 0 : if (!type_check (mask, 0, BT_INTEGER))
8237 : return false;
8238 :
8239 0 : if (!scalar_check (mask, 0))
8240 : return false;
8241 :
8242 0 : if (old == NULL)
8243 : return true;
8244 :
8245 0 : if (!scalar_check (old, 1))
8246 : return false;
8247 :
8248 0 : if (!type_check (old, 1, BT_INTEGER))
8249 : return false;
8250 :
8251 : return true;
8252 : }
8253 :
8254 :
8255 : bool
8256 2 : gfc_check_unlink (gfc_expr *name)
8257 : {
8258 2 : if (!type_check (name, 0, BT_CHARACTER))
8259 : return false;
8260 2 : if (!kind_value_check (name, 0, gfc_default_character_kind))
8261 : return false;
8262 :
8263 : return true;
8264 : }
8265 :
8266 :
8267 : bool
8268 12 : gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
8269 : {
8270 12 : if (!type_check (name, 0, BT_CHARACTER))
8271 : return false;
8272 12 : if (!kind_value_check (name, 0, gfc_default_character_kind))
8273 : return false;
8274 :
8275 10 : if (status == NULL)
8276 : return true;
8277 :
8278 1 : if (!scalar_check (status, 1))
8279 : return false;
8280 :
8281 1 : if (!type_check (status, 1, BT_INTEGER))
8282 : return false;
8283 :
8284 : return true;
8285 : }
8286 :
8287 :
8288 : bool
8289 1 : gfc_check_signal (gfc_expr *number, gfc_expr *handler)
8290 : {
8291 1 : if (!scalar_check (number, 0))
8292 : return false;
8293 1 : if (!type_check (number, 0, BT_INTEGER))
8294 : return false;
8295 :
8296 1 : if (!int_or_proc_check (handler, 1))
8297 : return false;
8298 1 : if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
8299 : return false;
8300 :
8301 : return true;
8302 : }
8303 :
8304 :
8305 : bool
8306 0 : gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
8307 : {
8308 0 : if (!scalar_check (number, 0))
8309 : return false;
8310 0 : if (!type_check (number, 0, BT_INTEGER))
8311 : return false;
8312 :
8313 0 : if (!int_or_proc_check (handler, 1))
8314 : return false;
8315 0 : if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
8316 : return false;
8317 :
8318 0 : if (status == NULL)
8319 : return true;
8320 :
8321 0 : if (!type_check (status, 2, BT_INTEGER))
8322 : return false;
8323 0 : if (!scalar_check (status, 2))
8324 : return false;
8325 :
8326 : return true;
8327 : }
8328 :
8329 :
8330 : bool
8331 0 : gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
8332 : {
8333 0 : if (!type_check (cmd, 0, BT_CHARACTER))
8334 : return false;
8335 0 : if (!kind_value_check (cmd, 0, gfc_default_character_kind))
8336 : return false;
8337 :
8338 0 : if (!scalar_check (status, 1))
8339 : return false;
8340 :
8341 0 : if (!type_check (status, 1, BT_INTEGER))
8342 : return false;
8343 :
8344 0 : if (!kind_value_check (status, 1, gfc_default_integer_kind))
8345 : return false;
8346 :
8347 : return true;
8348 : }
8349 :
8350 :
8351 : /* This is used for the GNU intrinsics AND, OR and XOR. */
8352 : bool
8353 164 : gfc_check_and (gfc_expr *i, gfc_expr *j)
8354 : {
8355 164 : if (i->ts.type != BT_INTEGER
8356 164 : && i->ts.type != BT_LOGICAL
8357 25 : && i->ts.type != BT_BOZ)
8358 : {
8359 3 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
8360 : "LOGICAL, or a BOZ literal constant",
8361 3 : gfc_current_intrinsic_arg[0]->name,
8362 : gfc_current_intrinsic, &i->where);
8363 3 : return false;
8364 : }
8365 :
8366 161 : if (j->ts.type != BT_INTEGER
8367 161 : && j->ts.type != BT_LOGICAL
8368 28 : && j->ts.type != BT_BOZ)
8369 : {
8370 3 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
8371 : "LOGICAL, or a BOZ literal constant",
8372 3 : gfc_current_intrinsic_arg[1]->name,
8373 : gfc_current_intrinsic, &j->where);
8374 3 : return false;
8375 : }
8376 :
8377 : /* i and j cannot both be BOZ literal constants. */
8378 158 : if (!boz_args_check (i, j))
8379 : return false;
8380 :
8381 : /* If i is BOZ and j is integer, convert i to type of j. */
8382 154 : if (i->ts.type == BT_BOZ)
8383 : {
8384 18 : if (j->ts.type != BT_INTEGER)
8385 : {
8386 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
8387 0 : gfc_current_intrinsic_arg[1]->name,
8388 : gfc_current_intrinsic, &j->where);
8389 0 : reset_boz (i);
8390 0 : return false;
8391 : }
8392 18 : if (!gfc_boz2int (i, j->ts.kind))
8393 : return false;
8394 : }
8395 :
8396 : /* If j is BOZ and i is integer, convert j to type of i. */
8397 154 : if (j->ts.type == BT_BOZ)
8398 : {
8399 21 : if (i->ts.type != BT_INTEGER)
8400 : {
8401 1 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
8402 1 : gfc_current_intrinsic_arg[0]->name,
8403 : gfc_current_intrinsic, &j->where);
8404 1 : reset_boz (j);
8405 1 : return false;
8406 : }
8407 20 : if (!gfc_boz2int (j, i->ts.kind))
8408 : return false;
8409 : }
8410 :
8411 153 : if (!same_type_check (i, 0, j, 1, false))
8412 : return false;
8413 :
8414 146 : if (!scalar_check (i, 0))
8415 : return false;
8416 :
8417 146 : if (!scalar_check (j, 1))
8418 : return false;
8419 :
8420 : return true;
8421 : }
8422 :
8423 :
8424 : bool
8425 1037 : gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
8426 : {
8427 :
8428 1037 : if (a->expr_type == EXPR_NULL)
8429 : {
8430 1 : gfc_error ("Intrinsic function NULL at %L cannot be an actual "
8431 : "argument to STORAGE_SIZE, because it returns a "
8432 : "disassociated pointer", &a->where);
8433 1 : return false;
8434 : }
8435 :
8436 1036 : if (a->ts.type == BT_ASSUMED)
8437 : {
8438 0 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
8439 0 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
8440 : &a->where);
8441 0 : return false;
8442 : }
8443 :
8444 1036 : if (a->ts.type == BT_PROCEDURE)
8445 : {
8446 1 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
8447 1 : "procedure", gfc_current_intrinsic_arg[0]->name,
8448 : gfc_current_intrinsic, &a->where);
8449 1 : return false;
8450 : }
8451 :
8452 1035 : if (a->ts.type == BT_BOZ && illegal_boz_arg (a))
8453 : return false;
8454 :
8455 1034 : if (kind == NULL)
8456 : return true;
8457 :
8458 303 : if (!type_check (kind, 1, BT_INTEGER))
8459 : return false;
8460 :
8461 302 : if (!scalar_check (kind, 1))
8462 : return false;
8463 :
8464 301 : if (kind->expr_type != EXPR_CONSTANT)
8465 : {
8466 1 : gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
8467 1 : gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
8468 : &kind->where);
8469 1 : return false;
8470 : }
8471 :
8472 : return true;
8473 : }
8474 :
8475 : /* Check two operands that either both or none of them can
8476 : be UNSIGNED. */
8477 :
8478 : bool
8479 431297 : gfc_invalid_unsigned_ops (gfc_expr * op1, gfc_expr * op2)
8480 : {
8481 431297 : return (op1->ts.type == BT_UNSIGNED) ^ (op2->ts.type == BT_UNSIGNED);
8482 : }
|
