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