Bug Summary

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