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