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