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 64827 : scalar_check (gfc_expr *e, int n)
500 : {
501 64827 : 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 193610 : type_check (gfc_expr *e, int n, bt type)
516 : {
517 193610 : if (e->ts.type == type)
518 : return true;
519 :
520 3483 : gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
521 3483 : gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
522 : &e->where, gfc_basic_typename (type));
523 :
524 3483 : 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 18766 : 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 18766 : if (e->symtree && e->symtree->n.sym->attr.subroutine)
550 1 : goto error;
551 :
552 18765 : 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 8210 : int_or_real_check (gfc_expr *e, int n)
580 : {
581 8210 : 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 3026 : real_or_complex_check (gfc_expr *e, int n)
693 : {
694 3026 : 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 87896 : kind_check (gfc_expr *k, int n, bt type)
728 : {
729 87896 : int kind;
730 :
731 87896 : if (k == NULL)
732 : return true;
733 :
734 9524 : if (!type_check (k, n, BT_INTEGER))
735 : return false;
736 :
737 9524 : if (!scalar_check (k, n))
738 : return false;
739 :
740 9522 : 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 9522 : if (gfc_extract_int (k, &kind)
749 9522 : || 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 15525 : double_check (gfc_expr *d, int n)
764 : {
765 15525 : if (!type_check (d, n, BT_REAL))
766 : return false;
767 :
768 12142 : if (d->ts.kind != gfc_default_double_kind)
769 : {
770 7127 : gfc_error ("%qs argument of %qs intrinsic at %L must be double "
771 7127 : "precision", gfc_current_intrinsic_arg[n]->name,
772 : gfc_current_intrinsic, &d->where);
773 7127 : 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 41090 : logical_array_check (gfc_expr *array, int n)
807 : {
808 41090 : 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 63142 : array_check (gfc_expr *e, int n)
824 : {
825 63142 : if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
826 1151 : && CLASS_DATA (e)->attr.dimension
827 64293 : && CLASS_DATA (e)->as->rank)
828 : {
829 1151 : gfc_add_class_array_ref (e);
830 : }
831 :
832 63142 : 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 11260 : nonnegative_check (const char *arg, gfc_expr *expr)
851 : {
852 11260 : int i;
853 :
854 11260 : if (expr->expr_type == EXPR_CONSTANT)
855 : {
856 10286 : gfc_extract_int (expr, &i);
857 10286 : 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 10164 : same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
1014 : {
1015 10164 : gfc_typespec *ets = &e->ts;
1016 10164 : gfc_typespec *fts = &f->ts;
1017 :
1018 10164 : 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 2365 : if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
1025 128 : ets = &e->symtree->n.sym->ts;
1026 2365 : if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
1027 127 : fts = &f->symtree->n.sym->ts;
1028 : }
1029 :
1030 10164 : 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 14869 : rank_check (gfc_expr *e, int n, int rank)
1046 : {
1047 14869 : 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 25557 : nonoptional_check (gfc_expr *e, int n)
1062 : {
1063 25557 : 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 25557 : return true;
1073 : }
1074 :
1075 :
1076 : /* Check for ALLOCATABLE attribute. */
1077 :
1078 : static bool
1079 7788 : allocatable_check (gfc_expr *e, int n)
1080 : {
1081 7788 : symbol_attribute attr;
1082 :
1083 7788 : attr = gfc_variable_attr (e, NULL);
1084 7788 : if (!attr.allocatable
1085 7778 : || (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 20234 : variable_check (gfc_expr *e, int n, bool allow_proc)
1147 : {
1148 20234 : if (e->expr_type == EXPR_VARIABLE
1149 20208 : && 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 20261 : && !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 20228 : if (e->expr_type == EXPR_VARIABLE
1161 20202 : && e->symtree->n.sym->attr.flavor != FL_PARAMETER
1162 20202 : && (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 93737 : dim_check (gfc_expr *dim, int n, bool optional)
1192 : {
1193 93737 : if (dim == NULL)
1194 : return true;
1195 :
1196 31283 : if (!type_check (dim, n, BT_INTEGER))
1197 : return false;
1198 :
1199 31267 : if (!scalar_check (dim, n))
1200 : return false;
1201 :
1202 31263 : 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 92079 : dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
1243 : {
1244 92079 : gfc_array_ref *ar;
1245 92079 : int rank;
1246 :
1247 92079 : if (dim == NULL)
1248 : return true;
1249 :
1250 29625 : if (dim->expr_type != EXPR_CONSTANT)
1251 : return true;
1252 :
1253 28184 : 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 28124 : rank = array->rank;
1258 :
1259 : /* Assumed-rank array. */
1260 28184 : if (rank == -1)
1261 1164 : rank = GFC_MAX_DIMENSIONS;
1262 :
1263 28184 : if (array->expr_type == EXPR_VARIABLE)
1264 : {
1265 26973 : ar = gfc_find_array_ref (array, true);
1266 26973 : if (!ar)
1267 : return false;
1268 26972 : 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 28183 : if (mpz_cmp_ui (dim->value.integer, 1) < 0
1276 28181 : || 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 2544 : identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
1294 : {
1295 2544 : mpz_t a_size, b_size;
1296 2544 : bool ret;
1297 :
1298 2544 : gcc_assert (a->rank > ai);
1299 2544 : gcc_assert (b->rank > bi);
1300 :
1301 2544 : ret = true;
1302 :
1303 2544 : 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 2544 : 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 4765 : gfc_var_strlen (const gfc_expr *a)
1323 : {
1324 4765 : gfc_ref *ra;
1325 :
1326 4765 : while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
1327 0 : a = a->value.op.op1;
1328 :
1329 6672 : for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
1330 : ;
1331 :
1332 4765 : 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 4558 : if (a->ts.u.cl && a->ts.u.cl->length
1355 2566 : && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1356 2485 : 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 4616 : gfc_check_abs (gfc_expr *a)
1452 : {
1453 4616 : 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 40741 : gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
1504 : {
1505 40741 : if (!logical_array_check (mask, 0))
1506 : return false;
1507 :
1508 40741 : if (!dim_check (dim, 1, false))
1509 : return false;
1510 :
1511 40741 : 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 7191 : 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 7191 : 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 7191 : if (!variable_check (array, 0, false))
1537 : return false;
1538 7190 : 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 1721 : gfc_check_mod (gfc_expr *a, gfc_expr *p)
1577 : {
1578 1721 : if (flag_unsigned)
1579 : {
1580 78 : if (!int_or_real_or_unsigned_check (a,0))
1581 : return false;
1582 : }
1583 1643 : else if (!int_or_real_check (a, 0))
1584 : return false;
1585 :
1586 1721 : 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 1721 : 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 45042 : gfc_invalid_null_arg (gfc_expr *x)
1617 : {
1618 45042 : 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 7151 : gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
1630 : {
1631 7151 : symbol_attribute attr1, attr2;
1632 7151 : int i;
1633 7151 : bool t;
1634 :
1635 7151 : if (gfc_invalid_null_arg (pointer))
1636 : return false;
1637 :
1638 7150 : attr1 = gfc_expr_attr (pointer);
1639 :
1640 7150 : 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 7149 : 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 7148 : if (target == NULL)
1659 : return true;
1660 :
1661 2368 : if (gfc_invalid_null_arg (target))
1662 : return false;
1663 :
1664 2367 : if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
1665 2366 : 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 2366 : 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 2366 : 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 2365 : t = true;
1693 2365 : 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 2365 : if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank))
1698 : t = false;
1699 2365 : 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 76 : gfc_check_f_c_string (gfc_expr *string, gfc_expr *asis)
1879 : {
1880 :
1881 76 : if (gfc_invalid_null_arg (string))
1882 : return false;
1883 :
1884 76 : if (!scalar_check (string, 0))
1885 : return false;
1886 :
1887 76 : if (string->ts.type != BT_CHARACTER
1888 76 : || (string->ts.type == BT_CHARACTER
1889 76 : && (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 76 : if (asis)
1899 : {
1900 54 : if (!type_check (asis, 1, BT_LOGICAL))
1901 : return false;
1902 :
1903 54 : 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 179 : get_ul_from_cst_cl (const gfc_charlen *cl)
2502 : {
2503 179 : return cl && cl->length && cl->length->expr_type == EXPR_CONSTANT
2504 355 : ? 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 229 : gfc_check_dble (gfc_expr *x)
2935 : {
2936 229 : if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind))
2937 : return false;
2938 :
2939 229 : 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 749 : gfc_check_fn_c (gfc_expr *a)
3299 : {
3300 749 : 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 12829 : gfc_check_fn_d (gfc_expr *a)
3322 : {
3323 12829 : if (!double_check (a, 0))
3324 : return false;
3325 :
3326 : return true;
3327 : }
3328 :
3329 : /* A single real or complex argument. */
3330 :
3331 : bool
3332 995 : gfc_check_fn_rc (gfc_expr *a)
3333 : {
3334 995 : if (!real_or_complex_check (a, 0))
3335 : return false;
3336 :
3337 : return true;
3338 : }
3339 :
3340 :
3341 : bool
3342 1572 : gfc_check_fn_rc2008 (gfc_expr *a)
3343 : {
3344 1572 : if (!real_or_complex_check (a, 0))
3345 : return false;
3346 :
3347 1572 : if (a->ts.type == BT_COMPLEX
3348 2222 : && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs "
3349 : "of %qs intrinsic at %L",
3350 650 : gfc_current_intrinsic_arg[0]->name,
3351 : gfc_current_intrinsic, &a->where))
3352 : return false;
3353 :
3354 : return true;
3355 : }
3356 :
3357 :
3358 : bool
3359 0 : gfc_check_fnum (gfc_expr *unit)
3360 : {
3361 0 : if (!type_check (unit, 0, BT_INTEGER))
3362 : return false;
3363 :
3364 0 : if (!scalar_check (unit, 0))
3365 : return false;
3366 :
3367 : return true;
3368 : }
3369 :
3370 :
3371 : bool
3372 6153 : gfc_check_huge (gfc_expr *x)
3373 : {
3374 6153 : if (flag_unsigned)
3375 : {
3376 182 : if (!int_or_real_or_unsigned_check (x, 0))
3377 : return false;
3378 : }
3379 5971 : 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 5166 : gfc_check_kind (gfc_expr *x)
3835 : {
3836 5166 : if (gfc_invalid_null_arg (x))
3837 : return false;
3838 :
3839 5165 : 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 5163 : 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 6539 : gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3860 : {
3861 6539 : if (!array_check (array, 0))
3862 : return false;
3863 :
3864 6538 : if (!dim_check (dim, 1, false))
3865 : return false;
3866 :
3867 6538 : if (!dim_rank_check (dim, array, 1))
3868 : return false;
3869 :
3870 6538 : if (!kind_check (kind, 2, BT_INTEGER))
3871 : return false;
3872 6538 : 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 10906 : gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
3912 : {
3913 10906 : if (!type_check (s, 0, BT_CHARACTER))
3914 : return false;
3915 :
3916 10884 : if (gfc_invalid_null_arg (s))
3917 : return false;
3918 :
3919 10878 : if (!kind_check (kind, 1, BT_INTEGER))
3920 : return false;
3921 10878 : 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 4992 : min_max_args (gfc_actual_arglist *args)
4056 : {
4057 4992 : gfc_actual_arglist *arg;
4058 4992 : int i, j, nargs, *nlabels, nlabelless;
4059 4992 : bool a1 = false, a2 = false;
4060 :
4061 4992 : 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 4992 : if (!args->name)
4069 4980 : a1 = true;
4070 :
4071 4992 : if (!args->next->name)
4072 4979 : a2 = true;
4073 :
4074 4992 : nargs = 0;
4075 16454 : for (arg = args; arg; arg = arg->next)
4076 11462 : if (arg->name)
4077 38 : nargs++;
4078 :
4079 4992 : 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 2540 : check_rest (bt type, int kind, gfc_actual_arglist *arglist)
4140 : {
4141 2540 : gfc_actual_arglist *arg, *tmp;
4142 2540 : gfc_expr *x;
4143 2540 : int m, n;
4144 :
4145 2540 : if (!min_max_args (arglist))
4146 : return false;
4147 :
4148 8291 : for (arg = arglist, n=1; arg; arg = arg->next, n++)
4149 : {
4150 5798 : x = arg->expr;
4151 5798 : 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 10043 : for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
4174 4283 : if (!gfc_check_conformance (tmp->expr, x,
4175 4283 : _("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 2452 : gfc_check_min_max (gfc_actual_arglist *arg)
4187 : {
4188 2452 : gfc_expr *x;
4189 :
4190 2452 : if (!min_max_args (arg))
4191 : return false;
4192 :
4193 2450 : x = arg->expr;
4194 :
4195 2450 : 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 1929 : 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 1851 : 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 2449 : 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 950 : gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4269 : {
4270 950 : 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 947 : 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 944 : || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)
4288 1888 : || 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 943 : 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 798 : case 2:
4313 798 : if (matrix_b->rank != 2)
4314 : {
4315 159 : 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 798 : 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 7469 : check_reduction (gfc_actual_arglist *ap)
4536 : {
4537 7469 : gfc_expr *a, *m, *d;
4538 :
4539 7469 : a = ap->expr;
4540 7469 : d = ap->next->expr;
4541 7469 : m = ap->next->next->expr;
4542 :
4543 7469 : 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 7469 : if (!dim_check (d, 1, false))
4553 : return false;
4554 :
4555 7469 : if (!dim_rank_check (d, a, 0))
4556 : return false;
4557 :
4558 7466 : if (m != NULL && !type_check (m, 2, BT_LOGICAL))
4559 : return false;
4560 :
4561 7466 : if (m != NULL
4562 10861 : && !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 2876 : gfc_check_product_sum (gfc_actual_arglist *ap)
4593 : {
4594 2876 : if (!numeric_check (ap->expr, 0)
4595 2876 : || !array_check (ap->expr, 0))
4596 0 : return false;
4597 :
4598 2876 : 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 459 : gfc_check_precision (gfc_expr *x)
5111 : {
5112 459 : 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 180 : gfc_check_range (gfc_expr *x)
5181 : {
5182 180 : 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 3397 : gfc_check_real (gfc_expr *a, gfc_expr *kind)
5221 : {
5222 3397 : if (!kind_check (kind, 1, BT_REAL))
5223 : return false;
5224 :
5225 : /* BOZ is dealt with in gfc_simplify_real. */
5226 3397 : if (a->ts.type == BT_BOZ)
5227 : return true;
5228 :
5229 3312 : 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 9229 : gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
5356 : gfc_expr *pad, gfc_expr *order)
5357 : {
5358 9229 : mpz_t size;
5359 9229 : mpz_t nelems;
5360 9229 : int shape_size;
5361 9229 : bool shape_is_const;
5362 :
5363 9229 : if (!array_check (source, 0))
5364 : return false;
5365 :
5366 9228 : if (!rank_check (shape, 1, 1))
5367 : return false;
5368 :
5369 9228 : if (!type_check (shape, 1, BT_INTEGER))
5370 : return false;
5371 :
5372 9228 : 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 9228 : shape_size = mpz_get_ui (size);
5380 9228 : mpz_clear (size);
5381 :
5382 9228 : 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 9227 : 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 9226 : gfc_simplify_expr (shape, 0);
5397 9226 : shape_is_const = gfc_is_constant_array_expr (shape);
5398 :
5399 9226 : if (shape->expr_type == EXPR_ARRAY && shape_is_const)
5400 : {
5401 : gfc_expr *e;
5402 : int i, extent;
5403 25215 : for (i = 0; i < shape_size; ++i)
5404 : {
5405 17583 : e = gfc_constructor_lookup_expr (shape->value.constructor, i);
5406 17583 : if (e == NULL)
5407 : break;
5408 17583 : if (e->expr_type != EXPR_CONSTANT)
5409 0 : continue;
5410 :
5411 17583 : gfc_extract_int (e, &extent);
5412 17583 : 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 9222 : 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 9222 : 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 9218 : if (pad == NULL && shape->expr_type == EXPR_ARRAY && shape_is_const
5495 7312 : && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
5496 1908 : && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
5497 : {
5498 : /* Check the match in size between source and destination. */
5499 7311 : if (gfc_array_size (source, &nelems))
5500 : {
5501 7074 : gfc_constructor *c;
5502 7074 : bool test;
5503 :
5504 :
5505 7074 : mpz_init_set_ui (size, 1);
5506 7074 : for (c = gfc_constructor_first (shape->value.constructor);
5507 23246 : c; c = gfc_constructor_next (c))
5508 16172 : mpz_mul (size, size, c->expr->value.integer);
5509 :
5510 7074 : test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
5511 7074 : mpz_clear (nelems);
5512 7074 : mpz_clear (size);
5513 :
5514 7074 : 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 347 : gfc_check_selected_int_kind (gfc_expr *r)
5667 : {
5668 347 : if (!type_check (r, 0, BT_INTEGER))
5669 : return false;
5670 :
5671 347 : if (!scalar_check (r, 0))
5672 : return false;
5673 :
5674 : return true;
5675 : }
5676 :
5677 : bool
5678 722 : gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
5679 : {
5680 722 : if (p == NULL && r == NULL
5681 722 : && !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 721 : if (p)
5687 : {
5688 679 : if (!type_check (p, 0, BT_INTEGER))
5689 : return false;
5690 :
5691 679 : if (!scalar_check (p, 0))
5692 : return false;
5693 : }
5694 :
5695 720 : 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 719 : 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 7370 : gfc_check_shape (gfc_expr *source, gfc_expr *kind)
5737 : {
5738 7370 : gfc_array_ref *ar;
5739 :
5740 7370 : if (gfc_invalid_null_arg (source))
5741 : return false;
5742 :
5743 7369 : if (!kind_check (kind, 1, BT_INTEGER))
5744 : return false;
5745 7368 : 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 7368 : if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
5751 : return true;
5752 :
5753 7187 : if (source->ref == NULL)
5754 : return false;
5755 :
5756 7187 : ar = gfc_find_array_ref (source);
5757 :
5758 7187 : 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 12443 : gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5811 : {
5812 12443 : if (!array_check (array, 0))
5813 : return false;
5814 :
5815 12437 : if (!dim_check (dim, 1, true))
5816 : return false;
5817 :
5818 12436 : if (!dim_rank_check (dim, array, 0))
5819 : return false;
5820 :
5821 12432 : if (!kind_check (kind, 2, BT_INTEGER))
5822 : return false;
5823 12431 : 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 4760 : is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
5888 : {
5889 4760 : *msg = NULL;
5890 :
5891 4760 : 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 4759 : if (expr->ts.type == BT_BOZ)
5898 : {
5899 1 : *msg = _("BOZ literal constant");
5900 1 : return false;
5901 : }
5902 :
5903 4758 : if (expr->ts.type == BT_CLASS)
5904 : {
5905 0 : *msg = _("Expression is polymorphic");
5906 0 : return false;
5907 : }
5908 :
5909 4758 : 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 4717 : if (expr->ts.type == BT_PROCEDURE)
5917 : {
5918 4 : *msg = _("Procedure unexpected as argument");
5919 4 : return false;
5920 : }
5921 :
5922 4713 : 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 5307 : if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER
5933 4868 : && expr->ts.kind != 1)
5934 : {
5935 48 : *msg = _("Extension to use a non-C_CHAR-kind CHARACTER");
5936 48 : return false;
5937 : }
5938 :
5939 4653 : if (expr->ts.type == BT_CHARACTER) {
5940 127 : 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 126 : if (expr->ts.u.cl && expr->ts.u.cl->length
5949 195 : && !gfc_simplify_expr (expr->ts.u.cl->length, 0))
5950 0 : gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
5951 :
5952 126 : if (!c_loc
5953 29 : && expr->ts.u.cl
5954 155 : && !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 4652 : 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 4652 : if (!c_loc && !c_f_ptr && expr->rank > 0 && expr->expr_type == EXPR_VARIABLE)
5974 : {
5975 101 : gfc_array_ref *ar = gfc_find_array_ref (expr);
5976 101 : 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 432 : gfc_check_c_sizeof (gfc_expr *arg)
5989 : {
5990 432 : const char *msg;
5991 :
5992 432 : 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 423 : 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 423 : if (arg->rank && arg->expr_type == EXPR_VARIABLE
6011 101 : && arg->symtree->n.sym->as != NULL
6012 99 : && 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 2075 : bool check_c_ptr_1 (gfc_expr *c_ptr_1)
6030 : {
6031 2075 : if ((c_ptr_1->ts.type == BT_VOID)
6032 3 : && (c_ptr_1->expr_type == EXPR_FUNCTION))
6033 : return true;
6034 :
6035 2072 : if (c_ptr_1->ts.type != BT_DERIVED
6036 2063 : || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
6037 2062 : || (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 2062 : 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 2062 : 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 398 : bool check_c_ptr_2 (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
6062 : {
6063 398 : 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 387 : case BT_DERIVED:
6077 387 : 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 386 : 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 385 : if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING)
6089 1 : goto check_2_error;
6090 :
6091 384 : if (c_ptr_1->ts.type == BT_DERIVED
6092 382 : && (c_ptr_1->ts.u.derived->intmod_sym_id
6093 382 : != 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 385 : 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 2087 : gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
6119 : {
6120 2087 : if (c_ptr_2)
6121 : {
6122 398 : if (check_c_ptr_2 (c_ptr_1, c_ptr_2))
6123 386 : 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 647 : gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape,
6134 : gfc_expr *lower)
6135 : {
6136 647 : symbol_attribute attr;
6137 647 : const char *msg;
6138 :
6139 647 : if (cptr->ts.type != BT_DERIVED
6140 647 : || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
6141 647 : || 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 645 : if (!scalar_check (cptr, 0))
6149 : return false;
6150 :
6151 645 : attr = gfc_expr_attr (fptr);
6152 :
6153 645 : 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 644 : 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 643 : 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 643 : 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 642 : 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 641 : if (shape && !rank_check (shape, 2, 1))
6188 : return false;
6189 :
6190 640 : if (shape && !type_check (shape, 2, BT_INTEGER))
6191 : return false;
6192 :
6193 639 : 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 639 : if (lower
6210 639 : && !gfc_notify_std (GFC_STD_F2023, "LOWER argument at %L to C_F_POINTER",
6211 : &lower->where))
6212 : return false;
6213 :
6214 638 : 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 638 : if (lower && !rank_check (lower, 3, 1))
6223 : return false;
6224 :
6225 637 : if (lower && !type_check (lower, 3, BT_INTEGER))
6226 : return false;
6227 :
6228 636 : 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 636 : 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 636 : 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 634 : 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 86 : gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
6270 : {
6271 86 : symbol_attribute attr;
6272 :
6273 86 : if (cptr->ts.type != BT_DERIVED
6274 86 : || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
6275 86 : || 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 83 : if (!scalar_check (cptr, 0))
6283 : return false;
6284 :
6285 83 : attr = gfc_expr_attr (fptr);
6286 :
6287 83 : 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 83 : 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 83 : 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 : /* Handle both forms of this intrinsic, differentiated by whether
6310 : the first argument is a scalar or array. */
6311 :
6312 : bool
6313 74 : gfc_check_c_f_strpointer (gfc_expr *arg0, gfc_expr *fstrptr,
6314 : gfc_expr *nchars)
6315 : {
6316 74 : bool arg0_is_scalar = false;
6317 74 : const char *arg0name = "cstrarray";
6318 :
6319 74 : if (arg0->rank == 0)
6320 : {
6321 22 : arg0_is_scalar = true;
6322 22 : arg0name = "cstrptr";
6323 :
6324 : /* cstrptr is a scalar of type c_ptr. It is an intent in argument
6325 : holding the C address of a contiguous array s of nchars characters.
6326 : Its value must not be the C address of a Fortran variable without
6327 : the target attribute. */
6328 22 : if (arg0->ts.type != BT_DERIVED
6329 22 : || arg0->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
6330 22 : || arg0->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
6331 : {
6332 0 : gfc_error ("%qs argument of %qs intrinsic at %L shall be "
6333 : "a scalar of type C_PTR",
6334 : arg0name, gfc_current_intrinsic, &arg0->where);
6335 0 : return false;
6336 : }
6337 :
6338 22 : if (!nchars)
6339 : {
6340 1 : gfc_error ("%qs argument of %qs intrinsic shall be present "
6341 : "when the %qs argument at %L is a C_PTR",
6342 1 : gfc_current_intrinsic_arg[2]->name,
6343 : gfc_current_intrinsic, arg0name, &arg0->where);
6344 1 : return false;
6345 : }
6346 : }
6347 : else
6348 : {
6349 : /* arg0 is a rank-one character array of kind c_char and character
6350 : length one. It is an intent in argument. Its actual argument
6351 : must be simply contiguous and have the target attribute. */
6352 52 : if (arg0->rank != 1
6353 51 : || arg0->ts.type != BT_CHARACTER
6354 51 : || arg0->ts.kind != gfc_default_character_kind
6355 103 : || get_ul_from_cst_cl (arg0->ts.u.cl) != 1)
6356 : {
6357 2 : gfc_error ("%qs argument of %qs intrinsic at %L shall be "
6358 : "a rank-one character array of kind C_CHAR and "
6359 : "character length one",
6360 : arg0name, gfc_current_intrinsic, &arg0->where);
6361 2 : return false;
6362 : }
6363 50 : if (!gfc_is_simply_contiguous (arg0, true, false))
6364 : {
6365 1 : gfc_error ("%qs argument of %qs intrinsic at %L shall be "
6366 : "simply contiguous",
6367 : arg0name, gfc_current_intrinsic, &arg0->where);
6368 1 : return false;
6369 : }
6370 49 : if (!gfc_expr_attr (arg0).target)
6371 : {
6372 1 : gfc_error ("%qs argument of %qs intrinsic at %L shall have "
6373 : "the TARGET attribute",
6374 : arg0name, gfc_current_intrinsic, &arg0->where);
6375 1 : return false;
6376 : }
6377 :
6378 : /* If cstrarray is assumed-size, nchars must be present. */
6379 48 : if (!nchars)
6380 : {
6381 36 : gfc_array_ref *ar = gfc_find_array_ref (arg0);
6382 36 : if (ar->as && ar->as->type == AS_ASSUMED_SIZE
6383 4 : && (ar->type == AR_FULL || ar->end[0] == nullptr))
6384 : {
6385 1 : gfc_error ("%qs argument of %qs intrinsic shall be present "
6386 : "when the %qs argument at %L is assumed-size",
6387 1 : gfc_current_intrinsic_arg[2]->name,
6388 : gfc_current_intrinsic, arg0name, &arg0->where);
6389 1 : return false;
6390 : }
6391 : }
6392 : }
6393 :
6394 : /* fstrptr is a scalar deferred-length character pointer of kind c_char.
6395 : It is an intent out argument [...] */
6396 68 : if (fstrptr->rank != 0
6397 68 : || fstrptr->ts.type != BT_CHARACTER
6398 68 : || fstrptr->ts.kind != gfc_default_character_kind
6399 68 : || !fstrptr->ts.deferred
6400 135 : || !gfc_expr_attr (fstrptr).pointer)
6401 : {
6402 2 : gfc_error ("%qs argument of %qs intrinsic at %L shall be "
6403 : "a scalar deferred-length character pointer of kind C_CHAR",
6404 2 : gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
6405 : &fstrptr->where);
6406 2 : return false;
6407 : }
6408 66 : if (gfc_expr_attr (fstrptr).intent == INTENT_IN)
6409 : {
6410 1 : gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)",
6411 1 : gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
6412 : &fstrptr->where);
6413 1 : return false;
6414 : }
6415 :
6416 : /* For the array form: nchars is an optional integer scalar with intent in.
6417 : If nchars is present, its value must be nonnegative and not greater
6418 : than the size of cstrarray.
6419 : For the scalar form: nchars is an integer scalar with intent in. Its
6420 : value must be nonnegative. */
6421 65 : if (!nchars)
6422 : return true;
6423 30 : if (nchars->rank != 0 || nchars->ts.type != BT_INTEGER)
6424 : {
6425 0 : gfc_error ("%qs argument of %qs intrinsic at %L shall be "
6426 : "a scalar integer",
6427 0 : gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
6428 : &nchars->where);
6429 0 : return false;
6430 : }
6431 30 : if (nchars->expr_type != EXPR_CONSTANT)
6432 : return true;
6433 12 : if (!nonnegative_check (gfc_current_intrinsic_arg[2]->name, nchars))
6434 : return false;
6435 12 : if (!arg0_is_scalar)
6436 : {
6437 0 : mpz_t asize;
6438 0 : if (gfc_array_size (arg0, &asize)
6439 0 : && mpz_cmp (nchars->value.integer, asize) > 0)
6440 : {
6441 0 : gfc_error ("%qs at %L must not be greater than the size of %qs",
6442 0 : gfc_current_intrinsic_arg[2]->name, &nchars->where,
6443 : arg0name);
6444 0 : return false;
6445 : }
6446 : }
6447 :
6448 : return true;
6449 : }
6450 :
6451 : bool
6452 269 : gfc_check_c_funloc (gfc_expr *x)
6453 : {
6454 269 : symbol_attribute attr;
6455 :
6456 269 : if (gfc_is_coindexed (x))
6457 : {
6458 0 : gfc_error ("Argument X at %L to C_FUNLOC shall not be "
6459 : "coindexed", &x->where);
6460 0 : return false;
6461 : }
6462 :
6463 269 : attr = gfc_expr_attr (x);
6464 :
6465 269 : if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE
6466 135 : && x->symtree->n.sym == x->symtree->n.sym->result)
6467 74 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
6468 46 : if (x->symtree->n.sym == ns->proc_name)
6469 : {
6470 3 : gfc_error ("Function result %qs at %L is invalid as X argument "
6471 : "to C_FUNLOC", x->symtree->n.sym->name, &x->where);
6472 3 : return false;
6473 : }
6474 :
6475 266 : if (attr.flavor != FL_PROCEDURE)
6476 : {
6477 1 : gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
6478 : "or a procedure pointer", &x->where);
6479 1 : return false;
6480 : }
6481 :
6482 265 : if (!attr.is_bind_c)
6483 100 : return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure "
6484 100 : "at %L to C_FUNLOC", &x->where);
6485 : return true;
6486 : }
6487 :
6488 :
6489 : bool
6490 3847 : gfc_check_c_loc (gfc_expr *x)
6491 : {
6492 3847 : symbol_attribute attr;
6493 3847 : const char *msg;
6494 :
6495 3847 : if (gfc_is_coindexed (x))
6496 : {
6497 1 : gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
6498 1 : return false;
6499 : }
6500 :
6501 3846 : if (x->ts.type == BT_CLASS)
6502 : {
6503 1 : gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
6504 : &x->where);
6505 1 : return false;
6506 : }
6507 :
6508 3845 : attr = gfc_expr_attr (x);
6509 :
6510 3845 : if (!attr.pointer
6511 2449 : && (x->expr_type != EXPR_VARIABLE || !attr.target
6512 2445 : || attr.flavor == FL_PARAMETER))
6513 : {
6514 4 : gfc_error ("Argument X at %L to C_LOC shall have either "
6515 : "the POINTER or the TARGET attribute", &x->where);
6516 4 : return false;
6517 : }
6518 :
6519 3841 : if (x->ts.type == BT_CHARACTER
6520 3841 : && gfc_var_strlen (x) == 0)
6521 : {
6522 0 : gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
6523 : "string", &x->where);
6524 0 : return false;
6525 : }
6526 :
6527 3841 : if (!is_c_interoperable (x, &msg, true, false))
6528 : {
6529 76 : if (x->ts.type == BT_CLASS)
6530 : {
6531 0 : gfc_error ("Argument at %L to C_LOC shall not be polymorphic",
6532 : &x->where);
6533 0 : return false;
6534 : }
6535 :
6536 76 : if (x->rank
6537 76 : && !gfc_notify_std (GFC_STD_F2018,
6538 : "Noninteroperable array at %L as"
6539 : " argument to C_LOC: %s", &x->where, msg))
6540 : return false;
6541 : }
6542 3765 : else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008))
6543 : {
6544 7 : gfc_array_ref *ar = gfc_find_array_ref (x);
6545 :
6546 6 : if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
6547 5 : && !attr.allocatable
6548 11 : && !gfc_notify_std (GFC_STD_F2008,
6549 : "Array of interoperable type at %L "
6550 : "to C_LOC which is nonallocatable and neither "
6551 : "assumed size nor explicit size", &x->where))
6552 : return false;
6553 3 : else if (ar->type != AR_FULL
6554 3 : && !gfc_notify_std (GFC_STD_F2008, "Array section at %L "
6555 : "to C_LOC", &x->where))
6556 : return false;
6557 : }
6558 :
6559 : return true;
6560 : }
6561 :
6562 :
6563 : bool
6564 28 : gfc_check_sleep_sub (gfc_expr *seconds)
6565 : {
6566 28 : if (!type_check (seconds, 0, BT_INTEGER))
6567 : return false;
6568 :
6569 28 : if (!scalar_check (seconds, 0))
6570 : return false;
6571 :
6572 : return true;
6573 : }
6574 :
6575 : bool
6576 3 : gfc_check_sngl (gfc_expr *a)
6577 : {
6578 3 : if (!type_check (a, 0, BT_REAL))
6579 : return false;
6580 :
6581 3 : if ((a->ts.kind != gfc_default_double_kind)
6582 3 : && !gfc_notify_std (GFC_STD_GNU, "non double precision "
6583 : "REAL argument to %s intrinsic at %L",
6584 : gfc_current_intrinsic, &a->where))
6585 : return false;
6586 :
6587 : return true;
6588 : }
6589 :
6590 : bool
6591 741 : gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
6592 : {
6593 741 : if (gfc_invalid_null_arg (source))
6594 : return false;
6595 :
6596 740 : if (source->rank >= GFC_MAX_DIMENSIONS)
6597 : {
6598 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be less "
6599 0 : "than rank %d", gfc_current_intrinsic_arg[0]->name,
6600 : gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
6601 :
6602 0 : return false;
6603 : }
6604 :
6605 740 : if (dim == NULL)
6606 : return false;
6607 :
6608 740 : if (!dim_check (dim, 1, false))
6609 : return false;
6610 :
6611 : /* dim_rank_check() does not apply here. */
6612 740 : if (dim
6613 740 : && dim->expr_type == EXPR_CONSTANT
6614 692 : && (mpz_cmp_ui (dim->value.integer, 1) < 0
6615 691 : || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
6616 : {
6617 2 : gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
6618 2 : "dimension index", gfc_current_intrinsic_arg[1]->name,
6619 : gfc_current_intrinsic, &dim->where);
6620 2 : return false;
6621 : }
6622 :
6623 738 : if (!type_check (ncopies, 2, BT_INTEGER))
6624 : return false;
6625 :
6626 738 : if (!scalar_check (ncopies, 2))
6627 : return false;
6628 :
6629 : return true;
6630 : }
6631 :
6632 :
6633 : /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
6634 : functions). */
6635 :
6636 : bool
6637 157 : arg_strlen_is_zero (gfc_expr *c, int n)
6638 : {
6639 157 : if (gfc_var_strlen (c) == 0)
6640 : {
6641 2 : gfc_error ("%qs argument of %qs intrinsic at %L must have "
6642 2 : "length at least 1", gfc_current_intrinsic_arg[n]->name,
6643 : gfc_current_intrinsic, &c->where);
6644 2 : return true;
6645 : }
6646 : return false;
6647 : }
6648 :
6649 : bool
6650 155 : gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
6651 : {
6652 155 : if (!type_check (unit, 0, BT_INTEGER))
6653 : return false;
6654 :
6655 155 : if (!scalar_check (unit, 0))
6656 : return false;
6657 :
6658 155 : if (!type_check (c, 1, BT_CHARACTER))
6659 : return false;
6660 155 : if (!kind_value_check (c, 1, gfc_default_character_kind))
6661 : return false;
6662 149 : if (strcmp (gfc_current_intrinsic, "fgetc") == 0
6663 149 : && !variable_check (c, 1, false))
6664 : return false;
6665 148 : if (arg_strlen_is_zero (c, 1))
6666 : return false;
6667 :
6668 147 : if (status == NULL)
6669 : return true;
6670 :
6671 58 : if (!type_check (status, 2, BT_INTEGER)
6672 58 : || !kind_value_check (status, 2, gfc_default_integer_kind)
6673 58 : || !scalar_check (status, 2)
6674 116 : || !variable_check (status, 2, false))
6675 2 : return false;
6676 :
6677 : return true;
6678 : }
6679 :
6680 :
6681 : bool
6682 71 : gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
6683 : {
6684 71 : return gfc_check_fgetputc_sub (unit, c, NULL);
6685 : }
6686 :
6687 :
6688 : bool
6689 17 : gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
6690 : {
6691 17 : if (!type_check (c, 0, BT_CHARACTER))
6692 : return false;
6693 17 : if (!kind_value_check (c, 0, gfc_default_character_kind))
6694 : return false;
6695 11 : if (strcmp (gfc_current_intrinsic, "fget") == 0
6696 11 : && !variable_check (c, 0, false))
6697 : return false;
6698 9 : if (arg_strlen_is_zero (c, 0))
6699 : return false;
6700 :
6701 8 : if (status == NULL)
6702 : return true;
6703 :
6704 2 : if (!type_check (status, 1, BT_INTEGER)
6705 2 : || !kind_value_check (status, 1, gfc_default_integer_kind)
6706 2 : || !scalar_check (status, 1)
6707 4 : || !variable_check (status, 1, false))
6708 0 : return false;
6709 :
6710 : return true;
6711 : }
6712 :
6713 :
6714 : bool
6715 8 : gfc_check_fgetput (gfc_expr *c)
6716 : {
6717 8 : return gfc_check_fgetput_sub (c, NULL);
6718 : }
6719 :
6720 :
6721 : bool
6722 60 : gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
6723 : {
6724 60 : if (!type_check (unit, 0, BT_INTEGER))
6725 : return false;
6726 :
6727 60 : if (!scalar_check (unit, 0))
6728 : return false;
6729 :
6730 60 : if (!type_check (offset, 1, BT_INTEGER))
6731 : return false;
6732 :
6733 60 : if (!scalar_check (offset, 1))
6734 : return false;
6735 :
6736 60 : if (!type_check (whence, 2, BT_INTEGER))
6737 : return false;
6738 :
6739 60 : if (!scalar_check (whence, 2))
6740 : return false;
6741 :
6742 60 : if (status == NULL)
6743 : return true;
6744 :
6745 54 : if (!type_check (status, 3, BT_INTEGER))
6746 : return false;
6747 :
6748 54 : if (!kind_value_check (status, 3, 4))
6749 : return false;
6750 :
6751 54 : if (!scalar_check (status, 3))
6752 : return false;
6753 :
6754 : return true;
6755 : }
6756 :
6757 :
6758 :
6759 : bool
6760 43 : gfc_check_fstat (gfc_expr *unit, gfc_expr *values)
6761 : {
6762 43 : if (!type_check (unit, 0, BT_INTEGER))
6763 : return false;
6764 :
6765 43 : if (!scalar_check (unit, 0))
6766 : return false;
6767 :
6768 43 : if (!type_check (values, 1, BT_INTEGER))
6769 : return false;
6770 :
6771 43 : if (values->ts.kind != 4 && values->ts.kind != 8)
6772 : {
6773 1 : error_unsupported_kind (values, 1);
6774 1 : return false;
6775 : }
6776 :
6777 42 : if (!array_check (values, 1))
6778 : return false;
6779 :
6780 42 : if (!variable_check (values, 1, false))
6781 : return false;
6782 :
6783 40 : if (!array_size_check (values, 1, 13))
6784 : return false;
6785 :
6786 : return true;
6787 : }
6788 :
6789 :
6790 : bool
6791 28 : gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *values, gfc_expr *status)
6792 : {
6793 28 : if (!gfc_check_fstat (unit, values))
6794 : return false;
6795 :
6796 25 : if (status == NULL)
6797 : return true;
6798 :
6799 19 : if (!type_check (status, 2, BT_INTEGER)
6800 19 : || !check_minrange4 (status, 2))
6801 1 : return false;
6802 :
6803 18 : if (!scalar_check (status, 2))
6804 : return false;
6805 :
6806 18 : if (!variable_check (status, 2, false))
6807 : return false;
6808 :
6809 : return true;
6810 : }
6811 :
6812 :
6813 : bool
6814 102 : gfc_check_ftell (gfc_expr *unit)
6815 : {
6816 102 : if (!type_check (unit, 0, BT_INTEGER))
6817 : return false;
6818 :
6819 102 : if (!scalar_check (unit, 0))
6820 : return false;
6821 :
6822 : return true;
6823 : }
6824 :
6825 :
6826 : bool
6827 36 : gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
6828 : {
6829 36 : if (!type_check (unit, 0, BT_INTEGER))
6830 : return false;
6831 :
6832 36 : if (!scalar_check (unit, 0))
6833 : return false;
6834 :
6835 36 : if (!type_check (offset, 1, BT_INTEGER))
6836 : return false;
6837 :
6838 36 : if (!scalar_check (offset, 1))
6839 : return false;
6840 :
6841 : return true;
6842 : }
6843 :
6844 :
6845 : bool
6846 86 : gfc_check_stat (gfc_expr *name, gfc_expr *values)
6847 : {
6848 86 : if (!type_check (name, 0, BT_CHARACTER))
6849 : return false;
6850 86 : if (!kind_value_check (name, 0, gfc_default_character_kind))
6851 : return false;
6852 :
6853 80 : if (!type_check (values, 1, BT_INTEGER))
6854 : return false;
6855 :
6856 80 : if (values->ts.kind != 4 && values->ts.kind != 8)
6857 : {
6858 1 : error_unsupported_kind (values, 1);
6859 1 : return false;
6860 : }
6861 :
6862 79 : if (!array_check (values, 1))
6863 : return false;
6864 :
6865 79 : if (!variable_check (values, 1, false))
6866 : return false;
6867 :
6868 75 : if (!array_size_check (values, 1, 13))
6869 : return false;
6870 :
6871 : return true;
6872 : }
6873 :
6874 :
6875 : bool
6876 53 : gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status)
6877 : {
6878 53 : if (!gfc_check_stat (name, values))
6879 : return false;
6880 :
6881 45 : if (status == NULL)
6882 : return true;
6883 :
6884 39 : if (!type_check (status, 2, BT_INTEGER)
6885 39 : || !check_minrange4 (status, 2))
6886 1 : return false;
6887 :
6888 38 : if (!scalar_check (status, 2))
6889 : return false;
6890 :
6891 38 : if (!variable_check (status, 2, false))
6892 : return false;
6893 :
6894 : return true;
6895 : }
6896 :
6897 :
6898 : bool
6899 288 : gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub,
6900 : gfc_expr *team_or_team_number)
6901 : {
6902 288 : mpz_t nelems;
6903 :
6904 288 : if (flag_coarray == GFC_FCOARRAY_NONE)
6905 : {
6906 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
6907 : gfc_current_intrinsic_where);
6908 : return false;
6909 : }
6910 :
6911 288 : if (!coarray_check (coarray, 0))
6912 : return false;
6913 :
6914 287 : if (sub->rank != 1)
6915 : {
6916 1 : gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
6917 1 : gfc_current_intrinsic_arg[1]->name, &sub->where);
6918 1 : return false;
6919 : }
6920 :
6921 286 : if (!type_check (sub, 1, BT_INTEGER))
6922 : return false;
6923 :
6924 285 : if (gfc_array_size (sub, &nelems))
6925 : {
6926 285 : if (mpz_cmp_ui (nelems, coarray->corank) != 0)
6927 : {
6928 3 : gfc_error ("The number of array elements of the SUB argument to "
6929 : "IMAGE_INDEX at %L shall be %d (corank) not %d",
6930 3 : &sub->where, coarray->corank, (int) mpz_get_si (nelems));
6931 3 : mpz_clear (nelems);
6932 3 : return false;
6933 : }
6934 282 : mpz_clear (nelems);
6935 : }
6936 :
6937 282 : if (team_or_team_number)
6938 : {
6939 0 : if (!type_check2 (team_or_team_number, 2, BT_DERIVED, BT_INTEGER)
6940 0 : || !scalar_check (team_or_team_number, 2))
6941 0 : return false;
6942 :
6943 : /* Check team is of team_type. */
6944 0 : if (team_or_team_number->ts.type == BT_DERIVED
6945 0 : && !team_type_check (team_or_team_number, 2))
6946 : return false;
6947 : }
6948 :
6949 : return true;
6950 : }
6951 :
6952 : bool
6953 1247 : gfc_check_num_images (gfc_expr *team_or_team_number)
6954 : {
6955 1247 : if (flag_coarray == GFC_FCOARRAY_NONE)
6956 : {
6957 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
6958 : gfc_current_intrinsic_where);
6959 : return false;
6960 : }
6961 :
6962 1247 : if (!team_or_team_number)
6963 : return true;
6964 :
6965 33 : if (!gfc_notify_std (GFC_STD_F2008,
6966 : "%<team%> or %<team_number%> argument to %qs at %L",
6967 : gfc_current_intrinsic, &team_or_team_number->where))
6968 : return false;
6969 :
6970 33 : if (!type_check2 (team_or_team_number, 0, BT_DERIVED, BT_INTEGER)
6971 33 : || !scalar_check (team_or_team_number, 0))
6972 1 : return false;
6973 :
6974 32 : if (team_or_team_number->ts.type == BT_DERIVED
6975 32 : && !team_type_check (team_or_team_number, 0))
6976 : return false;
6977 :
6978 : return true;
6979 : }
6980 :
6981 :
6982 : bool
6983 35 : gfc_check_team_number (gfc_expr *team)
6984 : {
6985 35 : if (flag_coarray == GFC_FCOARRAY_NONE)
6986 : {
6987 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
6988 : gfc_current_intrinsic_where);
6989 : return false;
6990 : }
6991 :
6992 35 : return !team || (scalar_check (team, 0) && team_type_check (team, 0));
6993 : }
6994 :
6995 :
6996 : bool
6997 2210 : gfc_check_this_image (gfc_actual_arglist *args)
6998 : {
6999 2210 : gfc_expr *coarray, *dim, *team, *cur;
7000 :
7001 2210 : coarray = dim = team = NULL;
7002 :
7003 2210 : if (flag_coarray == GFC_FCOARRAY_NONE)
7004 : {
7005 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
7006 : gfc_current_intrinsic_where);
7007 : return false;
7008 : }
7009 :
7010 : /* Shortcut when no arguments are given. */
7011 2210 : if (!args->expr && !args->next->expr && !args->next->next->expr)
7012 : return true;
7013 :
7014 636 : cur = args->expr;
7015 :
7016 636 : if (cur)
7017 : {
7018 635 : gfc_push_suppress_errors ();
7019 635 : if (coarray_check (cur, 0))
7020 : coarray = cur;
7021 15 : else if (scalar_check (cur, 2) && team_type_check (cur, 2))
7022 : team = cur;
7023 : else
7024 : {
7025 1 : gfc_pop_suppress_errors ();
7026 1 : gfc_error ("First argument of %<this_image%> intrinsic at %L must be "
7027 : "a coarray "
7028 : "variable or an object of type %<team_type%> from the "
7029 : "intrinsic module "
7030 : "%<ISO_FORTRAN_ENV%>",
7031 : &cur->where);
7032 1 : return false;
7033 : }
7034 634 : gfc_pop_suppress_errors ();
7035 : }
7036 :
7037 635 : cur = args->next->expr;
7038 635 : if (cur)
7039 : {
7040 490 : gfc_push_suppress_errors ();
7041 490 : if (dim_check (cur, 1, true) && cur->corank == 0)
7042 : dim = cur;
7043 18 : else if (scalar_check (cur, 2) && team_type_check (cur, 2))
7044 : {
7045 14 : if (team)
7046 : {
7047 0 : gfc_pop_suppress_errors ();
7048 0 : goto team_type_error;
7049 : }
7050 : team = cur;
7051 : }
7052 : else
7053 : {
7054 4 : gfc_pop_suppress_errors ();
7055 4 : gfc_error ("Second argument of %<this_image%> intrinsic at %L must "
7056 : "be an %<INTEGER%> "
7057 : "typed scalar or an object of type %<team_type%> from the "
7058 : "intrinsic "
7059 : "module %<ISO_FORTRAN_ENV%>",
7060 : &cur->where);
7061 4 : return false;
7062 : }
7063 486 : gfc_pop_suppress_errors ();
7064 : }
7065 :
7066 631 : cur = args->next->next->expr;
7067 631 : if (cur)
7068 : {
7069 15 : if (team_type_check (cur, 2) && scalar_check (cur, 2))
7070 : {
7071 14 : if (team)
7072 0 : goto team_type_error;
7073 : team = cur;
7074 : }
7075 : else
7076 1 : return false;
7077 : }
7078 :
7079 630 : if (dim != NULL && coarray == NULL)
7080 : {
7081 1 : gfc_error ("%<dim%> argument without %<coarray%> argument not allowed "
7082 : "for %<this_image%> intrinsic at %L",
7083 : &dim->where);
7084 1 : return false;
7085 : }
7086 :
7087 629 : if (dim && !dim_corank_check (dim, coarray))
7088 : return false;
7089 :
7090 628 : if (team
7091 628 : && !gfc_notify_std (GFC_STD_F2018,
7092 : "%<team%> argument to %<this_image%> at %L",
7093 : &team->where))
7094 : return false;
7095 :
7096 628 : args->expr = coarray;
7097 628 : args->next->expr = dim;
7098 628 : args->next->next->expr = team;
7099 628 : return true;
7100 :
7101 0 : team_type_error:
7102 0 : gfc_error (
7103 : "At most one argument of type %<team_type%> from the intrinsic module "
7104 : "%<ISO_FORTRAN_ENV%> to %<this_image%> at %L allowed",
7105 : &cur->where);
7106 0 : return false;
7107 : }
7108 :
7109 : /* Calculate the sizes for transfer, used by gfc_check_transfer and also
7110 : by gfc_simplify_transfer. Return false if we cannot do so. */
7111 :
7112 : bool
7113 945 : gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size,
7114 : size_t *source_size, size_t *result_size,
7115 : size_t *result_length_p)
7116 : {
7117 945 : size_t result_elt_size;
7118 :
7119 945 : if (source->expr_type == EXPR_FUNCTION)
7120 : return false;
7121 :
7122 944 : if (size && size->expr_type != EXPR_CONSTANT)
7123 : return false;
7124 :
7125 : /* Calculate the size of the source. */
7126 943 : if (!gfc_target_expr_size (source, source_size))
7127 : return false;
7128 :
7129 : /* Determine the size of the element. */
7130 942 : if (!gfc_element_size (mold, &result_elt_size))
7131 : return false;
7132 :
7133 : /* If the storage size of SOURCE is greater than zero and MOLD is an array,
7134 : * a scalar with the type and type parameters of MOLD shall not have a
7135 : * storage size equal to zero.
7136 : * If MOLD is a scalar and SIZE is absent, the result is a scalar.
7137 : * If MOLD is an array and SIZE is absent, the result is an array and of
7138 : * rank one. Its size is as small as possible such that its physical
7139 : * representation is not shorter than that of SOURCE.
7140 : * If SIZE is present, the result is an array of rank one and size SIZE.
7141 : */
7142 916 : if (result_elt_size == 0 && *source_size > 0
7143 14 : && (mold->expr_type == EXPR_ARRAY || mold->rank))
7144 : {
7145 8 : gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an "
7146 : "array and shall not have storage size 0 when %<SOURCE%> "
7147 : "argument has size greater than 0", &mold->where);
7148 8 : return false;
7149 : }
7150 :
7151 908 : if (result_elt_size == 0 && *source_size == 0 && !size)
7152 : {
7153 41 : *result_size = 0;
7154 41 : if (result_length_p)
7155 40 : *result_length_p = 0;
7156 41 : return true;
7157 : }
7158 :
7159 867 : if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank))
7160 672 : || size)
7161 : {
7162 195 : int result_length;
7163 :
7164 195 : if (size)
7165 167 : result_length = (size_t)mpz_get_ui (size->value.integer);
7166 : else
7167 : {
7168 132 : result_length = *source_size / result_elt_size;
7169 132 : if (result_length * result_elt_size < *source_size)
7170 0 : result_length += 1;
7171 : }
7172 :
7173 279 : *result_size = result_length * result_elt_size;
7174 279 : if (result_length_p)
7175 271 : *result_length_p = result_length;
7176 : }
7177 : else
7178 588 : *result_size = result_elt_size;
7179 :
7180 : return true;
7181 : }
7182 :
7183 :
7184 : bool
7185 2211 : gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
7186 : {
7187 2211 : size_t source_size;
7188 2211 : size_t result_size;
7189 :
7190 2211 : if (gfc_invalid_null_arg (source))
7191 : return false;
7192 :
7193 : /* SOURCE shall be a scalar or array of any type. */
7194 2208 : if (source->ts.type == BT_PROCEDURE
7195 3 : && source->symtree->n.sym->attr.subroutine == 1)
7196 : {
7197 1 : gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
7198 : "must not be a %s", &source->where,
7199 : gfc_basic_typename (source->ts.type));
7200 1 : return false;
7201 : }
7202 :
7203 2207 : if (source->ts.type == BT_BOZ && illegal_boz_arg (source))
7204 : return false;
7205 :
7206 2206 : if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold))
7207 : return false;
7208 :
7209 2205 : if (gfc_invalid_null_arg (mold))
7210 : return false;
7211 :
7212 : /* MOLD shall be a scalar or array of any type. */
7213 2203 : if (mold->ts.type == BT_PROCEDURE
7214 2 : && mold->symtree->n.sym->attr.subroutine == 1)
7215 : {
7216 1 : gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
7217 : "must not be a %s", &mold->where,
7218 : gfc_basic_typename (mold->ts.type));
7219 1 : return false;
7220 : }
7221 :
7222 2202 : if (mold->ts.type == BT_HOLLERITH)
7223 : {
7224 1 : gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
7225 : " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
7226 1 : return false;
7227 : }
7228 :
7229 : /* SIZE (optional) shall be an integer scalar. The corresponding actual
7230 : argument shall not be an optional dummy argument. */
7231 2201 : if (size != NULL)
7232 : {
7233 368 : if (!type_check (size, 2, BT_INTEGER))
7234 : {
7235 1 : if (size->ts.type == BT_BOZ)
7236 1 : reset_boz (size);
7237 1 : return false;
7238 : }
7239 :
7240 367 : if (!scalar_check (size, 2))
7241 : return false;
7242 :
7243 367 : if (!nonoptional_check (size, 2))
7244 : return false;
7245 : }
7246 :
7247 2200 : if (!warn_surprising)
7248 : return true;
7249 :
7250 : /* If we can't calculate the sizes, we cannot check any more.
7251 : Return true for that case. */
7252 :
7253 52 : if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
7254 : &result_size, NULL))
7255 : return true;
7256 :
7257 49 : if (source_size < result_size)
7258 6 : gfc_warning (OPT_Wsurprising,
7259 : "Intrinsic TRANSFER at %L has partly undefined result: "
7260 : "source size %zd < result size %zd", &source->where,
7261 : source_size, result_size);
7262 :
7263 : return true;
7264 : }
7265 :
7266 :
7267 : bool
7268 1175 : gfc_check_transpose (gfc_expr *matrix)
7269 : {
7270 1175 : if (!rank_check (matrix, 0, 2))
7271 : return false;
7272 :
7273 : return true;
7274 : }
7275 :
7276 :
7277 : bool
7278 7196 : gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
7279 : {
7280 7196 : if (!array_check (array, 0))
7281 : return false;
7282 :
7283 7195 : if (!dim_check (dim, 1, false))
7284 : return false;
7285 :
7286 7195 : if (!dim_rank_check (dim, array, 0))
7287 : return false;
7288 :
7289 7193 : if (!kind_check (kind, 2, BT_INTEGER))
7290 : return false;
7291 7193 : if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
7292 : "with KIND argument at %L",
7293 : gfc_current_intrinsic, &kind->where))
7294 : return false;
7295 :
7296 : return true;
7297 : }
7298 :
7299 :
7300 : bool
7301 344 : gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
7302 : {
7303 344 : if (flag_coarray == GFC_FCOARRAY_NONE)
7304 : {
7305 0 : gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable",
7306 : gfc_current_intrinsic_where);
7307 : return false;
7308 : }
7309 :
7310 344 : if (!coarray_check (coarray, 0))
7311 : return false;
7312 :
7313 340 : if (dim != NULL)
7314 : {
7315 224 : if (!dim_check (dim, 1, false))
7316 : return false;
7317 :
7318 224 : if (!dim_corank_check (dim, coarray))
7319 : return false;
7320 : }
7321 :
7322 340 : if (!kind_check (kind, 2, BT_INTEGER))
7323 : return false;
7324 :
7325 : return true;
7326 : }
7327 :
7328 :
7329 : bool
7330 393 : gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
7331 : {
7332 393 : mpz_t vector_size;
7333 :
7334 393 : if (!rank_check (vector, 0, 1))
7335 : return false;
7336 :
7337 393 : if (!array_check (mask, 1))
7338 : return false;
7339 :
7340 393 : if (!type_check (mask, 1, BT_LOGICAL))
7341 : return false;
7342 :
7343 393 : if (!same_type_check (vector, 0, field, 2))
7344 : return false;
7345 :
7346 393 : gfc_simplify_expr (mask, 0);
7347 :
7348 393 : if (mask->expr_type == EXPR_ARRAY
7349 393 : && gfc_array_size (vector, &vector_size))
7350 : {
7351 40 : int mask_true_count = 0;
7352 40 : gfc_constructor *mask_ctor;
7353 40 : mask_ctor = gfc_constructor_first (mask->value.constructor);
7354 263 : while (mask_ctor)
7355 : {
7356 183 : if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
7357 : {
7358 : mask_true_count = 0;
7359 : break;
7360 : }
7361 :
7362 183 : if (mask_ctor->expr->value.logical)
7363 78 : mask_true_count++;
7364 :
7365 183 : mask_ctor = gfc_constructor_next (mask_ctor);
7366 : }
7367 :
7368 40 : if (mpz_get_si (vector_size) < mask_true_count)
7369 : {
7370 1 : gfc_error ("%qs argument of %qs intrinsic at %L must "
7371 : "provide at least as many elements as there "
7372 : "are .TRUE. values in %qs (%ld/%d)",
7373 1 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
7374 1 : &vector->where, gfc_current_intrinsic_arg[1]->name,
7375 : mpz_get_si (vector_size), mask_true_count);
7376 1 : return false;
7377 : }
7378 :
7379 39 : mpz_clear (vector_size);
7380 : }
7381 :
7382 392 : if (mask->rank != field->rank && field->rank != 0)
7383 : {
7384 0 : gfc_error ("%qs argument of %qs intrinsic at %L must have "
7385 : "the same rank as %qs or be a scalar",
7386 0 : gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
7387 0 : &field->where, gfc_current_intrinsic_arg[1]->name);
7388 0 : return false;
7389 : }
7390 :
7391 392 : if (mask->rank == field->rank)
7392 : {
7393 : int i;
7394 712 : for (i = 0; i < field->rank; i++)
7395 452 : if (! identical_dimen_shape (mask, i, field, i))
7396 : {
7397 5 : gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
7398 : "must have identical shape.",
7399 5 : gfc_current_intrinsic_arg[2]->name,
7400 5 : gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
7401 : &field->where);
7402 : }
7403 : }
7404 :
7405 : return true;
7406 : }
7407 :
7408 :
7409 : bool
7410 250 : gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
7411 : {
7412 250 : if (!type_check (x, 0, BT_CHARACTER))
7413 : return false;
7414 :
7415 250 : if (!same_type_check (x, 0, y, 1))
7416 : return false;
7417 :
7418 250 : if (z != NULL && !type_check (z, 2, BT_LOGICAL))
7419 : return false;
7420 :
7421 250 : if (!kind_check (kind, 3, BT_INTEGER))
7422 : return false;
7423 250 : if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
7424 : "with KIND argument at %L",
7425 : gfc_current_intrinsic, &kind->where))
7426 : return false;
7427 :
7428 : return true;
7429 : }
7430 :
7431 :
7432 : bool
7433 2091 : gfc_check_trim (gfc_expr *x)
7434 : {
7435 2091 : if (!type_check (x, 0, BT_CHARACTER))
7436 : return false;
7437 :
7438 2091 : if (gfc_invalid_null_arg (x))
7439 : return false;
7440 :
7441 2090 : if (!scalar_check (x, 0))
7442 : return false;
7443 :
7444 : return true;
7445 : }
7446 :
7447 :
7448 : bool
7449 0 : gfc_check_ttynam (gfc_expr *unit)
7450 : {
7451 0 : if (!scalar_check (unit, 0))
7452 : return false;
7453 :
7454 0 : if (!type_check (unit, 0, BT_INTEGER))
7455 : return false;
7456 :
7457 : return true;
7458 : }
7459 :
7460 :
7461 : /************* Check functions for intrinsic subroutines *************/
7462 :
7463 : bool
7464 21 : gfc_check_cpu_time (gfc_expr *time)
7465 : {
7466 21 : if (!scalar_check (time, 0))
7467 : return false;
7468 :
7469 21 : if (!type_check (time, 0, BT_REAL))
7470 : return false;
7471 :
7472 21 : if (!variable_check (time, 0, false))
7473 : return false;
7474 :
7475 : return true;
7476 : }
7477 :
7478 :
7479 : bool
7480 183 : gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
7481 : gfc_expr *zone, gfc_expr *values)
7482 : {
7483 183 : if (date != NULL)
7484 : {
7485 71 : if (!type_check (date, 0, BT_CHARACTER))
7486 : return false;
7487 71 : if (!kind_value_check (date, 0, gfc_default_character_kind))
7488 : return false;
7489 69 : if (!scalar_check (date, 0))
7490 : return false;
7491 69 : if (!variable_check (date, 0, false))
7492 : return false;
7493 : }
7494 :
7495 181 : if (time != NULL)
7496 : {
7497 79 : if (!type_check (time, 1, BT_CHARACTER))
7498 : return false;
7499 79 : if (!kind_value_check (time, 1, gfc_default_character_kind))
7500 : return false;
7501 78 : if (!scalar_check (time, 1))
7502 : return false;
7503 78 : if (!variable_check (time, 1, false))
7504 : return false;
7505 : }
7506 :
7507 180 : if (zone != NULL)
7508 : {
7509 70 : if (!type_check (zone, 2, BT_CHARACTER))
7510 : return false;
7511 70 : if (!kind_value_check (zone, 2, gfc_default_character_kind))
7512 : return false;
7513 69 : if (!scalar_check (zone, 2))
7514 : return false;
7515 69 : if (!variable_check (zone, 2, false))
7516 : return false;
7517 : }
7518 :
7519 179 : if (values != NULL)
7520 : {
7521 100 : if (!type_check (values, 3, BT_INTEGER))
7522 : return false;
7523 100 : if (!array_check (values, 3))
7524 : return false;
7525 100 : if (!rank_check (values, 3, 1))
7526 : return false;
7527 100 : if (!variable_check (values, 3, false))
7528 : return false;
7529 100 : if (!array_size_check (values, 3, 8))
7530 : return false;
7531 :
7532 99 : if (values->ts.kind != gfc_default_integer_kind
7533 99 : && !gfc_notify_std (GFC_STD_F2018, "VALUES argument of "
7534 : "DATE_AND_TIME at %L has non-default kind",
7535 : &values->where))
7536 : return false;
7537 :
7538 : /* F2018:16.9.59 DATE_AND_TIME
7539 : "VALUES shall be a rank-one array of type integer
7540 : with a decimal exponent range of at least four."
7541 : This is a hard limit also required by the implementation in
7542 : libgfortran. */
7543 99 : if (values->ts.kind < 2)
7544 : {
7545 1 : gfc_error ("VALUES argument of DATE_AND_TIME at %L must have "
7546 : "a decimal exponent range of at least four",
7547 : &values->where);
7548 1 : return false;
7549 : }
7550 : }
7551 :
7552 : return true;
7553 : }
7554 :
7555 :
7556 : bool
7557 203 : gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
7558 : gfc_expr *to, gfc_expr *topos)
7559 : {
7560 :
7561 203 : if (flag_unsigned)
7562 : {
7563 24 : if (!type_check2 (from, 0, BT_INTEGER, BT_UNSIGNED))
7564 : return false;
7565 : }
7566 : else
7567 : {
7568 179 : if (!type_check (from, 0, BT_INTEGER))
7569 : return false;
7570 : }
7571 :
7572 203 : if (!type_check (frompos, 1, BT_INTEGER))
7573 : return false;
7574 :
7575 203 : if (!type_check (len, 2, BT_INTEGER))
7576 : return false;
7577 :
7578 203 : if (!same_type_check (from, 0, to, 3))
7579 : return false;
7580 :
7581 203 : if (!variable_check (to, 3, false))
7582 : return false;
7583 :
7584 203 : if (!type_check (topos, 4, BT_INTEGER))
7585 : return false;
7586 :
7587 203 : if (!nonnegative_check ("frompos", frompos))
7588 : return false;
7589 :
7590 202 : if (!nonnegative_check ("topos", topos))
7591 : return false;
7592 :
7593 201 : if (!nonnegative_check ("len", len))
7594 : return false;
7595 :
7596 200 : if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len))
7597 : return false;
7598 :
7599 199 : if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len))
7600 : return false;
7601 :
7602 : return true;
7603 : }
7604 :
7605 :
7606 : /* Check the arguments for RANDOM_INIT. */
7607 :
7608 : bool
7609 94 : gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
7610 : {
7611 94 : if (!type_check (repeatable, 0, BT_LOGICAL))
7612 : return false;
7613 :
7614 93 : if (!scalar_check (repeatable, 0))
7615 : return false;
7616 :
7617 92 : if (!type_check (image_distinct, 1, BT_LOGICAL))
7618 : return false;
7619 :
7620 91 : if (!scalar_check (image_distinct, 1))
7621 : return false;
7622 :
7623 : return true;
7624 : }
7625 :
7626 :
7627 : bool
7628 542 : gfc_check_random_number (gfc_expr *harvest)
7629 : {
7630 542 : if (flag_unsigned)
7631 : {
7632 78 : if (!type_check2 (harvest, 0, BT_REAL, BT_UNSIGNED))
7633 : return false;
7634 : }
7635 : else
7636 464 : if (!type_check (harvest, 0, BT_REAL))
7637 : return false;
7638 :
7639 542 : if (!variable_check (harvest, 0, false))
7640 : return false;
7641 :
7642 : return true;
7643 : }
7644 :
7645 :
7646 : bool
7647 304 : gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
7648 : {
7649 304 : unsigned int nargs = 0, seed_size;
7650 304 : locus *where = NULL;
7651 304 : mpz_t put_size, get_size;
7652 :
7653 : /* Keep the number of bytes in sync with master_state in
7654 : libgfortran/intrinsics/random.c. */
7655 304 : seed_size = 32 / gfc_default_integer_kind;
7656 :
7657 304 : if (size != NULL)
7658 : {
7659 90 : if (size->expr_type != EXPR_VARIABLE
7660 90 : || !size->symtree->n.sym->attr.optional)
7661 68 : nargs++;
7662 :
7663 90 : if (!scalar_check (size, 0))
7664 : return false;
7665 :
7666 90 : if (!type_check (size, 0, BT_INTEGER))
7667 : return false;
7668 :
7669 90 : if (!variable_check (size, 0, false))
7670 : return false;
7671 :
7672 89 : if (!kind_value_check (size, 0, gfc_default_integer_kind))
7673 : return false;
7674 : }
7675 :
7676 303 : if (put != NULL)
7677 : {
7678 117 : if (put->expr_type != EXPR_VARIABLE
7679 117 : || !put->symtree->n.sym->attr.optional)
7680 : {
7681 96 : nargs++;
7682 96 : where = &put->where;
7683 : }
7684 :
7685 117 : if (!array_check (put, 1))
7686 : return false;
7687 :
7688 117 : if (!rank_check (put, 1, 1))
7689 : return false;
7690 :
7691 117 : if (!type_check (put, 1, BT_INTEGER))
7692 : return false;
7693 :
7694 117 : if (!kind_value_check (put, 1, gfc_default_integer_kind))
7695 : return false;
7696 :
7697 117 : if (gfc_array_size (put, &put_size))
7698 : {
7699 5 : if (mpz_get_ui (put_size) < seed_size)
7700 3 : gfc_error ("Size of %qs argument of %qs intrinsic at %L "
7701 : "too small (%i/%i)",
7702 3 : gfc_current_intrinsic_arg[1]->name,
7703 : gfc_current_intrinsic,
7704 3 : &put->where, (int) mpz_get_ui (put_size), seed_size);
7705 5 : mpz_clear (put_size);
7706 : }
7707 : }
7708 :
7709 303 : if (get != NULL)
7710 : {
7711 136 : if (get->expr_type != EXPR_VARIABLE
7712 136 : || !get->symtree->n.sym->attr.optional)
7713 : {
7714 115 : nargs++;
7715 115 : where = &get->where;
7716 : }
7717 :
7718 136 : if (!array_check (get, 2))
7719 : return false;
7720 :
7721 136 : if (!rank_check (get, 2, 1))
7722 : return false;
7723 :
7724 136 : if (!type_check (get, 2, BT_INTEGER))
7725 : return false;
7726 :
7727 136 : if (!variable_check (get, 2, false))
7728 : return false;
7729 :
7730 136 : if (!kind_value_check (get, 2, gfc_default_integer_kind))
7731 : return false;
7732 :
7733 136 : if (gfc_array_size (get, &get_size))
7734 : {
7735 5 : if (mpz_get_ui (get_size) < seed_size)
7736 3 : gfc_error ("Size of %qs argument of %qs intrinsic at %L "
7737 : "too small (%i/%i)",
7738 3 : gfc_current_intrinsic_arg[2]->name,
7739 : gfc_current_intrinsic,
7740 3 : &get->where, (int) mpz_get_ui (get_size), seed_size);
7741 5 : mpz_clear (get_size);
7742 : }
7743 : }
7744 :
7745 : /* RANDOM_SEED may not have more than one non-optional argument. */
7746 303 : if (nargs > 1)
7747 1 : gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
7748 :
7749 : return true;
7750 : }
7751 :
7752 : bool
7753 393 : gfc_check_fe_runtime_error (gfc_actual_arglist *a)
7754 : {
7755 393 : gfc_expr *e;
7756 393 : size_t len, i;
7757 393 : int num_percent, nargs;
7758 :
7759 393 : e = a->expr;
7760 393 : if (e->expr_type != EXPR_CONSTANT)
7761 : return true;
7762 :
7763 393 : len = e->value.character.length;
7764 393 : if (e->value.character.string[len-1] != '\0')
7765 0 : gfc_internal_error ("fe_runtime_error string must be null terminated");
7766 :
7767 : num_percent = 0;
7768 27189 : for (i=0; i<len-1; i++)
7769 26796 : if (e->value.character.string[i] == '%')
7770 786 : num_percent ++;
7771 :
7772 : nargs = 0;
7773 1572 : for (; a; a = a->next)
7774 1179 : nargs ++;
7775 :
7776 393 : if (nargs -1 != num_percent)
7777 0 : gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)",
7778 : nargs, num_percent++);
7779 :
7780 : return true;
7781 : }
7782 :
7783 : bool
7784 0 : gfc_check_second_sub (gfc_expr *time)
7785 : {
7786 0 : if (!scalar_check (time, 0))
7787 : return false;
7788 :
7789 0 : if (!type_check (time, 0, BT_REAL))
7790 : return false;
7791 :
7792 0 : if (!kind_value_check (time, 0, 4))
7793 : return false;
7794 :
7795 : return true;
7796 : }
7797 :
7798 :
7799 : /* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
7800 : variables in Fortran 95. In Fortran 2003 and later, they can be of any
7801 : kind, and COUNT_RATE can be of type real. Note, count, count_rate, and
7802 : count_max are all optional arguments */
7803 :
7804 : bool
7805 212 : gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
7806 : gfc_expr *count_max)
7807 : {
7808 212 : int first_int_kind = -1;
7809 :
7810 212 : if (count != NULL)
7811 : {
7812 207 : if (!scalar_check (count, 0))
7813 : return false;
7814 :
7815 207 : if (!type_check (count, 0, BT_INTEGER))
7816 : return false;
7817 :
7818 207 : if (count->ts.kind != gfc_default_integer_kind
7819 207 : && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
7820 : "SYSTEM_CLOCK at %L has non-default kind",
7821 : &count->where))
7822 : return false;
7823 :
7824 206 : if (count->ts.kind < gfc_default_integer_kind
7825 206 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7826 : "COUNT argument to SYSTEM_CLOCK at %L "
7827 : "with kind smaller than default integer",
7828 : &count->where))
7829 : return false;
7830 :
7831 205 : if (!variable_check (count, 0, false))
7832 : return false;
7833 :
7834 205 : first_int_kind = count->ts.kind;
7835 : }
7836 :
7837 210 : if (count_rate != NULL)
7838 : {
7839 194 : if (!scalar_check (count_rate, 1))
7840 : return false;
7841 :
7842 194 : if (!variable_check (count_rate, 1, false))
7843 : return false;
7844 :
7845 194 : if (count_rate->ts.type == BT_REAL)
7846 : {
7847 120 : if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
7848 : "SYSTEM_CLOCK at %L", &count_rate->where))
7849 : return false;
7850 : }
7851 : else
7852 : {
7853 74 : if (!type_check (count_rate, 1, BT_INTEGER))
7854 : return false;
7855 :
7856 74 : if (count_rate->ts.kind != gfc_default_integer_kind
7857 74 : && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
7858 : "SYSTEM_CLOCK at %L has non-default kind",
7859 : &count_rate->where))
7860 : return false;
7861 :
7862 73 : if (count_rate->ts.kind < gfc_default_integer_kind
7863 73 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7864 : "COUNT_RATE argument to SYSTEM_CLOCK at %L "
7865 : "with kind smaller than default integer",
7866 : &count_rate->where))
7867 : return false;
7868 :
7869 72 : if (first_int_kind < 0)
7870 2 : first_int_kind = count_rate->ts.kind;
7871 : }
7872 :
7873 : }
7874 :
7875 206 : if (count_max != NULL)
7876 : {
7877 189 : if (!scalar_check (count_max, 2))
7878 : return false;
7879 :
7880 189 : if (!type_check (count_max, 2, BT_INTEGER))
7881 : return false;
7882 :
7883 189 : if (count_max->ts.kind != gfc_default_integer_kind
7884 189 : && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
7885 : "SYSTEM_CLOCK at %L has non-default kind",
7886 : &count_max->where))
7887 : return false;
7888 :
7889 188 : if (!variable_check (count_max, 2, false))
7890 : return false;
7891 :
7892 188 : if (count_max->ts.kind < gfc_default_integer_kind
7893 188 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7894 : "COUNT_MAX argument to SYSTEM_CLOCK at %L "
7895 : "with kind smaller than default integer",
7896 : &count_max->where))
7897 : return false;
7898 :
7899 187 : if (first_int_kind < 0)
7900 0 : first_int_kind = count_max->ts.kind;
7901 : }
7902 :
7903 204 : if (first_int_kind > 0)
7904 : {
7905 203 : if (count_rate
7906 188 : && count_rate->ts.type == BT_INTEGER
7907 71 : && count_rate->ts.kind != first_int_kind
7908 235 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7909 : "integer arguments to SYSTEM_CLOCK at %L "
7910 : "with different kind parameters",
7911 : &count_rate->where))
7912 : return false;
7913 :
7914 187 : if (count_max && count_max->ts.kind != first_int_kind
7915 284 : && !gfc_notify_std (GFC_STD_F2023_DEL,
7916 : "integer arguments to SYSTEM_CLOCK at %L "
7917 : "with different kind parameters",
7918 : &count_max->where))
7919 : return false;
7920 : }
7921 :
7922 : return true;
7923 : }
7924 :
7925 :
7926 : bool
7927 2 : gfc_check_irand (gfc_expr *x)
7928 : {
7929 2 : if (x == NULL)
7930 : return true;
7931 :
7932 0 : if (!scalar_check (x, 0))
7933 : return false;
7934 :
7935 0 : if (!type_check (x, 0, BT_INTEGER))
7936 : return false;
7937 :
7938 0 : if (!kind_value_check (x, 0, 4))
7939 : return false;
7940 :
7941 : return true;
7942 : }
7943 :
7944 :
7945 : bool
7946 0 : gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
7947 : {
7948 0 : if (!scalar_check (seconds, 0))
7949 : return false;
7950 0 : if (!type_check (seconds, 0, BT_INTEGER))
7951 : return false;
7952 :
7953 0 : if (!int_or_proc_check (handler, 1))
7954 : return false;
7955 0 : if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
7956 : return false;
7957 :
7958 0 : if (status == NULL)
7959 : return true;
7960 :
7961 0 : if (!scalar_check (status, 2))
7962 : return false;
7963 0 : if (!type_check (status, 2, BT_INTEGER))
7964 : return false;
7965 0 : if (!kind_value_check (status, 2, gfc_default_integer_kind))
7966 : return false;
7967 :
7968 : return true;
7969 : }
7970 :
7971 :
7972 : bool
7973 34 : gfc_check_rand (gfc_expr *x)
7974 : {
7975 34 : if (x == NULL)
7976 : return true;
7977 :
7978 1 : if (!scalar_check (x, 0))
7979 : return false;
7980 :
7981 1 : if (!type_check (x, 0, BT_INTEGER))
7982 : return false;
7983 :
7984 1 : if (!kind_value_check (x, 0, 4))
7985 : return false;
7986 :
7987 : return true;
7988 : }
7989 :
7990 :
7991 : bool
7992 0 : gfc_check_srand (gfc_expr *x)
7993 : {
7994 0 : if (!scalar_check (x, 0))
7995 : return false;
7996 :
7997 0 : if (!type_check (x, 0, BT_INTEGER))
7998 : return false;
7999 :
8000 0 : if (!kind_value_check (x, 0, 4))
8001 : return false;
8002 :
8003 : return true;
8004 : }
8005 :
8006 :
8007 : bool
8008 2 : gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
8009 : {
8010 2 : if (!scalar_check (time, 0))
8011 : return false;
8012 2 : if (!type_check (time, 0, BT_INTEGER))
8013 : return false;
8014 :
8015 2 : if (!type_check (result, 1, BT_CHARACTER))
8016 : return false;
8017 2 : if (!kind_value_check (result, 1, gfc_default_character_kind))
8018 : return false;
8019 :
8020 : return true;
8021 : }
8022 :
8023 :
8024 : bool
8025 1 : gfc_check_dtime_etime (gfc_expr *x)
8026 : {
8027 1 : if (!array_check (x, 0))
8028 : return false;
8029 :
8030 1 : if (!rank_check (x, 0, 1))
8031 : return false;
8032 :
8033 1 : if (!variable_check (x, 0, false))
8034 : return false;
8035 :
8036 1 : if (!type_check (x, 0, BT_REAL))
8037 : return false;
8038 :
8039 1 : if (!kind_value_check (x, 0, 4))
8040 : return false;
8041 :
8042 : return true;
8043 : }
8044 :
8045 :
8046 : bool
8047 1 : gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
8048 : {
8049 1 : if (!array_check (values, 0))
8050 : return false;
8051 :
8052 1 : if (!rank_check (values, 0, 1))
8053 : return false;
8054 :
8055 1 : if (!variable_check (values, 0, false))
8056 : return false;
8057 :
8058 1 : if (!type_check (values, 0, BT_REAL))
8059 : return false;
8060 :
8061 1 : if (!kind_value_check (values, 0, 4))
8062 : return false;
8063 :
8064 1 : if (!scalar_check (time, 1))
8065 : return false;
8066 :
8067 1 : if (!type_check (time, 1, BT_REAL))
8068 : return false;
8069 :
8070 1 : if (!kind_value_check (time, 1, 4))
8071 : return false;
8072 :
8073 : return true;
8074 : }
8075 :
8076 :
8077 : bool
8078 2 : gfc_check_fdate_sub (gfc_expr *date)
8079 : {
8080 2 : if (!type_check (date, 0, BT_CHARACTER))
8081 : return false;
8082 2 : if (!kind_value_check (date, 0, gfc_default_character_kind))
8083 : return false;
8084 :
8085 : return true;
8086 : }
8087 :
8088 :
8089 : bool
8090 3 : gfc_check_gerror (gfc_expr *msg)
8091 : {
8092 3 : if (!type_check (msg, 0, BT_CHARACTER))
8093 : return false;
8094 3 : if (!kind_value_check (msg, 0, gfc_default_character_kind))
8095 : return false;
8096 :
8097 : return true;
8098 : }
8099 :
8100 :
8101 : bool
8102 10 : gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
8103 : {
8104 10 : if (!type_check (cwd, 0, BT_CHARACTER))
8105 : return false;
8106 10 : if (!kind_value_check (cwd, 0, gfc_default_character_kind))
8107 : return false;
8108 :
8109 8 : if (status == NULL)
8110 : return true;
8111 :
8112 1 : if (!scalar_check (status, 1))
8113 : return false;
8114 :
8115 1 : if (!type_check (status, 1, BT_INTEGER))
8116 : return false;
8117 :
8118 : return true;
8119 : }
8120 :
8121 :
8122 : bool
8123 56 : gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
8124 : {
8125 56 : if (!type_check (pos, 0, BT_INTEGER))
8126 : return false;
8127 :
8128 56 : if (pos->ts.kind > gfc_default_integer_kind)
8129 : {
8130 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
8131 : "not wider than the default kind (%d)",
8132 0 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
8133 : &pos->where, gfc_default_integer_kind);
8134 0 : return false;
8135 : }
8136 :
8137 56 : if (!type_check (value, 1, BT_CHARACTER))
8138 : return false;
8139 56 : if (!kind_value_check (value, 1, gfc_default_character_kind))
8140 : return false;
8141 :
8142 : return true;
8143 : }
8144 :
8145 :
8146 : bool
8147 3 : gfc_check_getlog (gfc_expr *msg)
8148 : {
8149 3 : if (!type_check (msg, 0, BT_CHARACTER))
8150 : return false;
8151 3 : if (!kind_value_check (msg, 0, gfc_default_character_kind))
8152 : return false;
8153 :
8154 : return true;
8155 : }
8156 :
8157 :
8158 : bool
8159 3 : gfc_check_exit (gfc_expr *status)
8160 : {
8161 3 : if (status == NULL)
8162 : return true;
8163 :
8164 2 : if (!type_check (status, 0, BT_INTEGER))
8165 : return false;
8166 :
8167 2 : if (!scalar_check (status, 0))
8168 : return false;
8169 :
8170 : return true;
8171 : }
8172 :
8173 :
8174 : bool
8175 25 : gfc_check_flush (gfc_expr *unit)
8176 : {
8177 25 : if (unit == NULL)
8178 : return true;
8179 :
8180 12 : if (!type_check (unit, 0, BT_INTEGER))
8181 : return false;
8182 :
8183 12 : if (!scalar_check (unit, 0))
8184 : return false;
8185 :
8186 : return true;
8187 : }
8188 :
8189 :
8190 : bool
8191 10 : gfc_check_free (gfc_expr *i)
8192 : {
8193 10 : if (!type_check (i, 0, BT_INTEGER))
8194 : return false;
8195 :
8196 10 : if (!scalar_check (i, 0))
8197 : return false;
8198 :
8199 : return true;
8200 : }
8201 :
8202 :
8203 : bool
8204 5 : gfc_check_hostnm (gfc_expr *name)
8205 : {
8206 5 : if (!type_check (name, 0, BT_CHARACTER))
8207 : return false;
8208 5 : if (!kind_value_check (name, 0, gfc_default_character_kind))
8209 : return false;
8210 :
8211 : return true;
8212 : }
8213 :
8214 :
8215 : bool
8216 11 : gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
8217 : {
8218 11 : if (!type_check (name, 0, BT_CHARACTER))
8219 : return false;
8220 11 : if (!kind_value_check (name, 0, gfc_default_character_kind))
8221 : return false;
8222 :
8223 9 : if (status == NULL)
8224 : return true;
8225 :
8226 7 : if (!scalar_check (status, 1))
8227 : return false;
8228 :
8229 7 : if (!type_check (status, 1, BT_INTEGER))
8230 : return false;
8231 :
8232 : return true;
8233 : }
8234 :
8235 :
8236 : bool
8237 24 : gfc_check_itime_idate (gfc_expr *values)
8238 : {
8239 24 : if (!array_check (values, 0))
8240 : return false;
8241 :
8242 24 : if (!rank_check (values, 0, 1))
8243 : return false;
8244 :
8245 24 : if (!variable_check (values, 0, false))
8246 : return false;
8247 :
8248 24 : if (!type_check (values, 0, BT_INTEGER))
8249 : return false;
8250 :
8251 24 : if (!kind_value_check (values, 0, gfc_default_integer_kind))
8252 : return false;
8253 :
8254 : return true;
8255 : }
8256 :
8257 :
8258 : bool
8259 24 : gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
8260 : {
8261 24 : if (!type_check (time, 0, BT_INTEGER))
8262 : return false;
8263 :
8264 24 : if (!kind_value_check (time, 0, gfc_default_integer_kind))
8265 : return false;
8266 :
8267 24 : if (!scalar_check (time, 0))
8268 : return false;
8269 :
8270 24 : if (!array_check (values, 1))
8271 : return false;
8272 :
8273 24 : if (!rank_check (values, 1, 1))
8274 : return false;
8275 :
8276 24 : if (!variable_check (values, 1, false))
8277 : return false;
8278 :
8279 24 : if (!type_check (values, 1, BT_INTEGER))
8280 : return false;
8281 :
8282 24 : if (!kind_value_check (values, 1, gfc_default_integer_kind))
8283 : return false;
8284 :
8285 : return true;
8286 : }
8287 :
8288 :
8289 : bool
8290 2 : gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
8291 : {
8292 2 : if (!scalar_check (unit, 0))
8293 : return false;
8294 :
8295 2 : if (!type_check (unit, 0, BT_INTEGER))
8296 : return false;
8297 :
8298 2 : if (!type_check (name, 1, BT_CHARACTER))
8299 : return false;
8300 2 : if (!kind_value_check (name, 1, gfc_default_character_kind))
8301 : return false;
8302 :
8303 : return true;
8304 : }
8305 :
8306 :
8307 : bool
8308 836 : gfc_check_is_contiguous (gfc_expr *array)
8309 : {
8310 836 : if (array->expr_type == EXPR_NULL)
8311 : {
8312 2 : gfc_error ("Actual argument at %L of %qs intrinsic shall be an "
8313 : "associated pointer", &array->where, gfc_current_intrinsic);
8314 2 : return false;
8315 : }
8316 :
8317 834 : if (!array_check (array, 0))
8318 : return false;
8319 :
8320 : return true;
8321 : }
8322 :
8323 :
8324 : bool
8325 0 : gfc_check_isatty (gfc_expr *unit)
8326 : {
8327 0 : if (unit == NULL)
8328 : return false;
8329 :
8330 0 : if (!type_check (unit, 0, BT_INTEGER))
8331 : return false;
8332 :
8333 0 : if (!scalar_check (unit, 0))
8334 : return false;
8335 :
8336 : return true;
8337 : }
8338 :
8339 :
8340 : bool
8341 626 : gfc_check_isnan (gfc_expr *x)
8342 : {
8343 626 : if (!type_check (x, 0, BT_REAL))
8344 : return false;
8345 :
8346 : return true;
8347 : }
8348 :
8349 :
8350 : bool
8351 3 : gfc_check_perror (gfc_expr *string)
8352 : {
8353 3 : if (!type_check (string, 0, BT_CHARACTER))
8354 : return false;
8355 3 : if (!kind_value_check (string, 0, gfc_default_character_kind))
8356 : return false;
8357 :
8358 : return true;
8359 : }
8360 :
8361 :
8362 : bool
8363 0 : gfc_check_umask (gfc_expr *mask)
8364 : {
8365 0 : if (!type_check (mask, 0, BT_INTEGER))
8366 : return false;
8367 :
8368 0 : if (!scalar_check (mask, 0))
8369 : return false;
8370 :
8371 : return true;
8372 : }
8373 :
8374 :
8375 : bool
8376 0 : gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
8377 : {
8378 0 : if (!type_check (mask, 0, BT_INTEGER))
8379 : return false;
8380 :
8381 0 : if (!scalar_check (mask, 0))
8382 : return false;
8383 :
8384 0 : if (old == NULL)
8385 : return true;
8386 :
8387 0 : if (!scalar_check (old, 1))
8388 : return false;
8389 :
8390 0 : if (!type_check (old, 1, BT_INTEGER))
8391 : return false;
8392 :
8393 : return true;
8394 : }
8395 :
8396 :
8397 : bool
8398 2 : gfc_check_unlink (gfc_expr *name)
8399 : {
8400 2 : if (!type_check (name, 0, BT_CHARACTER))
8401 : return false;
8402 2 : if (!kind_value_check (name, 0, gfc_default_character_kind))
8403 : return false;
8404 :
8405 : return true;
8406 : }
8407 :
8408 :
8409 : bool
8410 12 : gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
8411 : {
8412 12 : if (!type_check (name, 0, BT_CHARACTER))
8413 : return false;
8414 12 : if (!kind_value_check (name, 0, gfc_default_character_kind))
8415 : return false;
8416 :
8417 10 : if (status == NULL)
8418 : return true;
8419 :
8420 1 : if (!scalar_check (status, 1))
8421 : return false;
8422 :
8423 1 : if (!type_check (status, 1, BT_INTEGER))
8424 : return false;
8425 :
8426 : return true;
8427 : }
8428 :
8429 :
8430 : bool
8431 1 : gfc_check_signal (gfc_expr *number, gfc_expr *handler)
8432 : {
8433 1 : if (!scalar_check (number, 0))
8434 : return false;
8435 1 : if (!type_check (number, 0, BT_INTEGER))
8436 : return false;
8437 :
8438 1 : if (!int_or_proc_check (handler, 1))
8439 : return false;
8440 1 : if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
8441 : return false;
8442 :
8443 : return true;
8444 : }
8445 :
8446 :
8447 : bool
8448 0 : gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
8449 : {
8450 0 : if (!scalar_check (number, 0))
8451 : return false;
8452 0 : if (!type_check (number, 0, BT_INTEGER))
8453 : return false;
8454 :
8455 0 : if (!int_or_proc_check (handler, 1))
8456 : return false;
8457 0 : if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1))
8458 : return false;
8459 :
8460 0 : if (status == NULL)
8461 : return true;
8462 :
8463 0 : if (!type_check (status, 2, BT_INTEGER))
8464 : return false;
8465 0 : if (!scalar_check (status, 2))
8466 : return false;
8467 :
8468 : return true;
8469 : }
8470 :
8471 :
8472 : bool
8473 0 : gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
8474 : {
8475 0 : if (!type_check (cmd, 0, BT_CHARACTER))
8476 : return false;
8477 0 : if (!kind_value_check (cmd, 0, gfc_default_character_kind))
8478 : return false;
8479 :
8480 0 : if (!scalar_check (status, 1))
8481 : return false;
8482 :
8483 0 : if (!type_check (status, 1, BT_INTEGER))
8484 : return false;
8485 :
8486 0 : if (!kind_value_check (status, 1, gfc_default_integer_kind))
8487 : return false;
8488 :
8489 : return true;
8490 : }
8491 :
8492 :
8493 : /* This is used for the GNU intrinsics AND, OR and XOR. */
8494 : bool
8495 164 : gfc_check_and (gfc_expr *i, gfc_expr *j)
8496 : {
8497 164 : if (i->ts.type != BT_INTEGER
8498 164 : && i->ts.type != BT_LOGICAL
8499 25 : && i->ts.type != BT_BOZ)
8500 : {
8501 3 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
8502 : "LOGICAL, or a BOZ literal constant",
8503 3 : gfc_current_intrinsic_arg[0]->name,
8504 : gfc_current_intrinsic, &i->where);
8505 3 : return false;
8506 : }
8507 :
8508 161 : if (j->ts.type != BT_INTEGER
8509 161 : && j->ts.type != BT_LOGICAL
8510 28 : && j->ts.type != BT_BOZ)
8511 : {
8512 3 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, "
8513 : "LOGICAL, or a BOZ literal constant",
8514 3 : gfc_current_intrinsic_arg[1]->name,
8515 : gfc_current_intrinsic, &j->where);
8516 3 : return false;
8517 : }
8518 :
8519 : /* i and j cannot both be BOZ literal constants. */
8520 158 : if (!boz_args_check (i, j))
8521 : return false;
8522 :
8523 : /* If i is BOZ and j is integer, convert i to type of j. */
8524 154 : if (i->ts.type == BT_BOZ)
8525 : {
8526 18 : if (j->ts.type != BT_INTEGER)
8527 : {
8528 0 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
8529 0 : gfc_current_intrinsic_arg[1]->name,
8530 : gfc_current_intrinsic, &j->where);
8531 0 : reset_boz (i);
8532 0 : return false;
8533 : }
8534 18 : if (!gfc_boz2int (i, j->ts.kind))
8535 : return false;
8536 : }
8537 :
8538 : /* If j is BOZ and i is integer, convert j to type of i. */
8539 154 : if (j->ts.type == BT_BOZ)
8540 : {
8541 21 : if (i->ts.type != BT_INTEGER)
8542 : {
8543 1 : gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
8544 1 : gfc_current_intrinsic_arg[0]->name,
8545 : gfc_current_intrinsic, &j->where);
8546 1 : reset_boz (j);
8547 1 : return false;
8548 : }
8549 20 : if (!gfc_boz2int (j, i->ts.kind))
8550 : return false;
8551 : }
8552 :
8553 153 : if (!same_type_check (i, 0, j, 1, false))
8554 : return false;
8555 :
8556 146 : if (!scalar_check (i, 0))
8557 : return false;
8558 :
8559 146 : if (!scalar_check (j, 1))
8560 : return false;
8561 :
8562 : return true;
8563 : }
8564 :
8565 :
8566 : bool
8567 1037 : gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
8568 : {
8569 :
8570 1037 : if (a->expr_type == EXPR_NULL)
8571 : {
8572 1 : gfc_error ("Intrinsic function NULL at %L cannot be an actual "
8573 : "argument to STORAGE_SIZE, because it returns a "
8574 : "disassociated pointer", &a->where);
8575 1 : return false;
8576 : }
8577 :
8578 1036 : if (a->ts.type == BT_ASSUMED)
8579 : {
8580 0 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
8581 0 : gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
8582 : &a->where);
8583 0 : return false;
8584 : }
8585 :
8586 1036 : if (a->ts.type == BT_PROCEDURE)
8587 : {
8588 1 : gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
8589 1 : "procedure", gfc_current_intrinsic_arg[0]->name,
8590 : gfc_current_intrinsic, &a->where);
8591 1 : return false;
8592 : }
8593 :
8594 1035 : if (a->ts.type == BT_BOZ && illegal_boz_arg (a))
8595 : return false;
8596 :
8597 1034 : if (kind == NULL)
8598 : return true;
8599 :
8600 303 : if (!type_check (kind, 1, BT_INTEGER))
8601 : return false;
8602 :
8603 302 : if (!scalar_check (kind, 1))
8604 : return false;
8605 :
8606 301 : if (kind->expr_type != EXPR_CONSTANT)
8607 : {
8608 1 : gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
8609 1 : gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
8610 : &kind->where);
8611 1 : return false;
8612 : }
8613 :
8614 : return true;
8615 : }
8616 :
8617 : /* Check two operands that either both or none of them can
8618 : be UNSIGNED. */
8619 :
8620 : bool
8621 431299 : gfc_invalid_unsigned_ops (gfc_expr * op1, gfc_expr * op2)
8622 : {
8623 431299 : return (op1->ts.type == BT_UNSIGNED) ^ (op2->ts.type == BT_UNSIGNED);
8624 : }
|
