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