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