Bug Summary

File:build/gcc/fortran/check.c
Warning:line 3671, column 22
The right operand of '==' is a garbage value

Annotated Source Code

Press '?' to see keyboard shortcuts

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