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