1/* Check functions 2 Copyright (C) 2002-2015 Free Software Foundation, Inc. 3 Contributed by Andy Vaught & Katherine Holcomb 4 5This file is part of GCC. 6 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 9Software Foundation; either version 3, or (at your option) any later 10version. 11 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. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21 22/* These functions check to see if an argument list is compatible with 23 a particular intrinsic function or subroutine. Presence of 24 required arguments has already been established, the argument list 25 has been sorted into the right order and has NULL arguments in the 26 correct places for missing optional arguments. */ 27 28#include "config.h" 29#include "system.h" 30#include "coretypes.h" 31#include "flags.h" 32#include "gfortran.h" 33#include "intrinsic.h" 34#include "constructor.h" 35#include "target-memory.h" 36 37 38/* Make sure an expression is a scalar. */ 39 40static bool 41scalar_check (gfc_expr *e, int n) 42{ 43 if (e->rank == 0) 44 return true; 45 46 gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar", 47 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 48 &e->where); 49 50 return false; 51} 52 53 54/* Check the type of an expression. */ 55 56static bool 57type_check (gfc_expr *e, int n, bt type) 58{ 59 if (e->ts.type == type) 60 return true; 61 62 gfc_error ("%qs argument of %qs intrinsic at %L must be %s", 63 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 64 &e->where, gfc_basic_typename (type)); 65 66 return false; 67} 68 69 70/* Check that the expression is a numeric type. */ 71 72static bool 73numeric_check (gfc_expr *e, int n) 74{ 75 if (gfc_numeric_ts (&e->ts)) 76 return true; 77 78 /* If the expression has not got a type, check if its namespace can 79 offer a default type. */ 80 if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) 81 && e->symtree->n.sym->ts.type == BT_UNKNOWN 82 && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns) 83 && gfc_numeric_ts (&e->symtree->n.sym->ts)) 84 { 85 e->ts = e->symtree->n.sym->ts; 86 return true; 87 } 88 89 gfc_error ("%qs argument of %qs intrinsic at %L must be a numeric type", 90 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 91 &e->where); 92 93 return false; 94} 95 96 97/* Check that an expression is integer or real. */ 98 99static bool 100int_or_real_check (gfc_expr *e, int n) 101{ 102 if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) 103 { 104 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " 105 "or REAL", gfc_current_intrinsic_arg[n]->name, 106 gfc_current_intrinsic, &e->where); 107 return false; 108 } 109 110 return true; 111} 112 113 114/* Check that an expression is real or complex. */ 115 116static bool 117real_or_complex_check (gfc_expr *e, int n) 118{ 119 if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) 120 { 121 gfc_error ("%qs argument of %qs intrinsic at %L must be REAL " 122 "or COMPLEX", gfc_current_intrinsic_arg[n]->name, 123 gfc_current_intrinsic, &e->where); 124 return false; 125 } 126 127 return true; 128} 129 130 131/* Check that an expression is INTEGER or PROCEDURE. */ 132 133static bool 134int_or_proc_check (gfc_expr *e, int n) 135{ 136 if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) 137 { 138 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " 139 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, 140 gfc_current_intrinsic, &e->where); 141 return false; 142 } 143 144 return true; 145} 146 147 148/* Check that the expression is an optional constant integer 149 and that it specifies a valid kind for that type. */ 150 151static bool 152kind_check (gfc_expr *k, int n, bt type) 153{ 154 int kind; 155 156 if (k == NULL) 157 return true; 158 159 if (!type_check (k, n, BT_INTEGER)) 160 return false; 161 162 if (!scalar_check (k, n)) 163 return false; 164 165 if (!gfc_check_init_expr (k)) 166 { 167 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", 168 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 169 &k->where); 170 return false; 171 } 172 173 if (gfc_extract_int (k, &kind) != NULL 174 || gfc_validate_kind (type, kind, true) < 0) 175 { 176 gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type), 177 &k->where); 178 return false; 179 } 180 181 return true; 182} 183 184 185/* Make sure the expression is a double precision real. */ 186 187static bool 188double_check (gfc_expr *d, int n) 189{ 190 if (!type_check (d, n, BT_REAL)) 191 return false; 192 193 if (d->ts.kind != gfc_default_double_kind) 194 { 195 gfc_error ("%qs argument of %qs intrinsic at %L must be double " 196 "precision", gfc_current_intrinsic_arg[n]->name, 197 gfc_current_intrinsic, &d->where); 198 return false; 199 } 200 201 return true; 202} 203 204 205static bool 206coarray_check (gfc_expr *e, int n) 207{ 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); 213 return true; 214 } 215 216 if (!gfc_is_coarray (e)) 217 { 218 gfc_error ("Expected coarray variable as %qs argument to the %s " 219 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, 220 gfc_current_intrinsic, &e->where); 221 return false; 222 } 223 224 return true; 225} 226 227 228/* Make sure the expression is a logical array. */ 229 230static bool 231logical_array_check (gfc_expr *array, int n) 232{ 233 if (array->ts.type != BT_LOGICAL || array->rank == 0) 234 { 235 gfc_error ("%qs argument of %qs intrinsic at %L must be a logical " 236 "array", gfc_current_intrinsic_arg[n]->name, 237 gfc_current_intrinsic, &array->where); 238 return false; 239 } 240 241 return true; 242} 243 244 245/* Make sure an expression is an array. */ 246 247static bool 248array_check (gfc_expr *e, int n) 249{ 250 if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok 251 && CLASS_DATA (e)->attr.dimension 252 && CLASS_DATA (e)->as->rank) 253 { 254 gfc_add_class_array_ref (e); 255 return true; 256 } 257 258 if (e->rank != 0 && e->ts.type != BT_PROCEDURE) 259 return true; 260 261 gfc_error ("%qs argument of %qs intrinsic at %L must be an array", 262 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 263 &e->where); 264 265 return false; 266} 267 268 269/* If expr is a constant, then check to ensure that it is greater than 270 of equal to zero. */ 271 272static bool 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 { 282 gfc_error ("%qs at %L must be nonnegative", arg, &expr->where); 283 return false; 284 } 285 } 286 287 return true; 288} 289 290 291/* If expr2 is constant, then check that the value is less than 292 (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ 293 294static bool 295less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, 296 gfc_expr *expr2, bool or_equal) 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); 304 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 " 314 "than or equal to BIT_SIZE(%qs)", 315 &expr2->where, arg1); 316 return false; 317 } 318 } 319 320 if (or_equal) 321 { 322 if (i2 > gfc_integer_kinds[i3].bit_size) 323 { 324 gfc_error ("%qs at %L must be less than " 325 "or equal to BIT_SIZE(%qs)", 326 arg2, &expr2->where, arg1); 327 return false; 328 } 329 } 330 else 331 { 332 if (i2 >= gfc_integer_kinds[i3].bit_size) 333 { 334 gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)", 335 arg2, &expr2->where, arg1); 336 return false; 337 } 338 } 339 } 340 341 return true; 342} 343 344 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 348static bool 349less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) 350{ 351 int i, val; 352 353 if (expr->expr_type != EXPR_CONSTANT) 354 return true; 355 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 { 361 gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of " 362 "INTEGER(KIND=%d)", arg, &expr->where, k); 363 return false; 364 } 365 366 return true; 367} 368 369 370/* If expr2 and expr3 are constants, then check that the value is less than 371 or equal to bit_size(expr1). */ 372 373static bool 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 { 387 gfc_error ("%<%s + %s%> at %L must be less than or equal " 388 "to BIT_SIZE(%qs)", 389 arg2, arg3, &expr2->where, arg1); 390 return false; 391 } 392 } 393 394 return true; 395} 396 397/* Make sure two expressions have the same type. */ 398 399static bool 400same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) 401{ 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)) 411 return true; 412 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, 415 gfc_current_intrinsic, &f->where, 416 gfc_current_intrinsic_arg[n]->name); 417 418 return false; 419} 420 421 422/* Make sure that an expression has a certain (nonzero) rank. */ 423 424static bool 425rank_check (gfc_expr *e, int n, int rank) 426{ 427 if (e->rank == rank) 428 return true; 429 430 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d", 431 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 432 &e->where, rank); 433 434 return false; 435} 436 437 438/* Make sure a variable expression is not an optional dummy argument. */ 439 440static bool 441nonoptional_check (gfc_expr *e, int n) 442{ 443 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) 444 { 445 gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL", 446 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 447 &e->where); 448 } 449 450 /* TODO: Recursive check on nonoptional variables? */ 451 452 return true; 453} 454 455 456/* Check for ALLOCATABLE attribute. */ 457 458static bool 459allocatable_check (gfc_expr *e, int n) 460{ 461 symbol_attribute attr; 462 463 attr = gfc_variable_attr (e, NULL); 464 if (!attr.allocatable || attr.associate_var) 465 { 466 gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE", 467 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 468 &e->where); 469 return false; 470 } 471 472 return true; 473} 474 475 476/* Check that an expression has a particular kind. */ 477 478static bool 479kind_value_check (gfc_expr *e, int n, int k) 480{ 481 if (e->ts.kind == k) 482 return true; 483 484 gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d", 485 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, 486 &e->where, k); 487 488 return false; 489} 490 491 492/* Make sure an expression is a variable. */ 493 494static bool 495variable_check (gfc_expr *e, int n, bool allow_proc) 496{ 497 if (e->expr_type == EXPR_VARIABLE 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)) 501 { 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; 518 } 519 520 if (!ref) 521 { 522 gfc_error ("%qs argument of %qs intrinsic at %L cannot be " 523 "INTENT(IN)", gfc_current_intrinsic_arg[n]->name, 524 gfc_current_intrinsic, &e->where); 525 return false; 526 } 527 } 528 529 if (e->expr_type == EXPR_VARIABLE 530 && e->symtree->n.sym->attr.flavor != FL_PARAMETER 531 && (allow_proc || !e->symtree->n.sym->attr.function)) 532 return true; 533 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) 540 return true; 541 } 542 543 gfc_error ("%qs argument of %qs intrinsic at %L must be a variable", 544 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); 545 546 return false; 547} 548 549 550/* Check the common DIM parameter for correctness. */ 551 552static bool 553dim_check (gfc_expr *dim, int n, bool optional) 554{ 555 if (dim == NULL) 556 return true; 557 558 if (!type_check (dim, n, BT_INTEGER)) 559 return false; 560 561 if (!scalar_check (dim, n)) 562 return false; 563 564 if (!optional && !nonoptional_check (dim, n)) 565 return false; 566 567 return true; 568} 569 570 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 574static bool 575dim_corank_check (gfc_expr *dim, gfc_expr *array) 576{ 577 int corank; 578 579 gcc_assert (array->expr_type == EXPR_VARIABLE); 580 581 if (dim->expr_type != EXPR_CONSTANT) 582 return true; 583 584 if (array->ts.type == BT_CLASS) 585 return true; 586 587 corank = gfc_get_corank (array); 588 589 if (mpz_cmp_ui (dim->value.integer, 1) < 0 590 || mpz_cmp_ui (dim->value.integer, corank) > 0) 591 { 592 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid " 593 "codimension index", gfc_current_intrinsic, &dim->where); 594 595 return false; 596 } 597 598 return true; 599} 600 601 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 607static bool 608dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) 609{ 610 gfc_array_ref *ar; 611 int rank; 612 613 if (dim == NULL) 614 return true; 615 616 if (dim->expr_type != EXPR_CONSTANT) 617 return true; 618 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 625 /* Assumed-rank array. */ 626 if (rank == -1) 627 rank = GFC_MAX_DIMENSIONS; 628 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 } 638 639 if (mpz_cmp_ui (dim->value.integer, 1) < 0 640 || mpz_cmp_ui (dim->value.integer, rank) > 0) 641 { 642 gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid " 643 "dimension index", gfc_current_intrinsic, &dim->where); 644 645 return false; 646 } 647 648 return true; 649} 650 651 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 667 if (gfc_array_dimen_size (a, ai, &a_size)) 668 { 669 if (gfc_array_dimen_size (b, bi, &b_size)) 670 { 671 if (mpz_cmp (a_size, b_size) != 0) 672 ret = 0; 673 674 mpz_clear (b_size); 675 } 676 mpz_clear (a_size); 677 } 678 return ret; 679} 680 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 700 if (!ra->u.ss.end) 701 return -1; 702 703 if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT) 704 && ra->u.ss.end->expr_type == EXPR_CONSTANT) 705 { 706 start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer) 707 : 1; 708 end_a = mpz_get_si (ra->u.ss.end->value.integer); 709 return (end_a < start_a) ? 0 : end_a - start_a + 1; 710 } 711 else if (ra->u.ss.start 712 && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0) 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} 728 729/* Check whether two character expressions have the same length; 730 returns true if they have or if the length cannot be determined, 731 otherwise return false and raise a gfc_error. */ 732 733bool 734gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) 735{ 736 long len_a, len_b; 737 738 len_a = gfc_var_strlen(a); 739 len_b = gfc_var_strlen(b); 740 741 if (len_a == -1 || len_b == -1 || len_a == len_b) 742 return true; 743 else 744 { 745 gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", 746 len_a, len_b, name, &a->where); 747 return false; 748 } 749} 750 751 752/***** Check functions *****/ 753 754/* Check subroutine suitable for intrinsics taking a real argument and 755 a kind argument for the result. */ 756 757static bool 758check_a_kind (gfc_expr *a, gfc_expr *kind, bt type) 759{ 760 if (!type_check (a, 0, BT_REAL)) 761 return false; 762 if (!kind_check (kind, 1, type)) 763 return false; 764 765 return true; 766} 767 768 769/* Check subroutine suitable for ceiling, floor and nint. */ 770 771bool 772gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) 773{ 774 return check_a_kind (a, kind, BT_INTEGER); 775} 776 777 778/* Check subroutine suitable for aint, anint. */ 779 780bool 781gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind) 782{ 783 return check_a_kind (a, kind, BT_REAL); 784} 785 786 787bool 788gfc_check_abs (gfc_expr *a) 789{ 790 if (!numeric_check (a, 0)) 791 return false; 792 793 return true; 794} 795 796 797bool 798gfc_check_achar (gfc_expr *a, gfc_expr *kind) 799{ 800 if (!type_check (a, 0, BT_INTEGER)) 801 return false; 802 if (!kind_check (kind, 1, BT_CHARACTER)) 803 return false; 804 805 return true; 806} 807 808 809bool 810gfc_check_access_func (gfc_expr *name, gfc_expr *mode) 811{ 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; 817 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; 823 824 return true; 825} 826 827 828bool 829gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) 830{ 831 if (!logical_array_check (mask, 0)) 832 return false; 833 834 if (!dim_check (dim, 1, false)) 835 return false; 836 837 if (!dim_rank_check (dim, mask, 0)) 838 return false; 839 840 return true; 841} 842 843 844bool 845gfc_check_allocated (gfc_expr *array) 846{ 847 if (!variable_check (array, 0, false)) 848 return false; 849 if (!allocatable_check (array, 0)) 850 return false; 851 852 return true; 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 859bool 860gfc_check_a_p (gfc_expr *a, gfc_expr *p) 861{ 862 if (!int_or_real_check (a, 0)) 863 return false; 864 865 if (a->ts.type != p->ts.type) 866 { 867 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " 868 "have the same type", gfc_current_intrinsic_arg[0]->name, 869 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 870 &p->where); 871 return false; 872 } 873 874 if (a->ts.kind != p->ts.kind) 875 { 876 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 877 &p->where)) 878 return false; 879 } 880 881 return true; 882} 883 884 885bool 886gfc_check_x_yd (gfc_expr *x, gfc_expr *y) 887{ 888 if (!double_check (x, 0) || !double_check (y, 1)) 889 return false; 890 891 return true; 892} 893 894 895bool 896gfc_check_associated (gfc_expr *pointer, gfc_expr *target) 897{ 898 symbol_attribute attr1, attr2; 899 int i; 900 bool t; 901 locus *where; 902 903 where = &pointer->where; 904 905 if (pointer->expr_type == EXPR_NULL) 906 goto null_arg; 907 908 attr1 = gfc_expr_attr (pointer); 909 910 if (!attr1.pointer && !attr1.proc_pointer) 911 { 912 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER", 913 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 914 &pointer->where); 915 return false; 916 } 917 918 /* F2008, C1242. */ 919 if (attr1.pointer && gfc_is_coindexed (pointer)) 920 { 921 gfc_error ("%qs argument of %qs intrinsic at %L shall not be " 922 "coindexed", gfc_current_intrinsic_arg[0]->name, 923 gfc_current_intrinsic, &pointer->where); 924 return false; 925 } 926 927 /* Target argument is optional. */ 928 if (target == NULL) 929 return true; 930 931 where = &target->where; 932 if (target->expr_type == EXPR_NULL) 933 goto null_arg; 934 935 if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) 936 attr2 = gfc_expr_attr (target); 937 else 938 { 939 gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer " 940 "or target VARIABLE or FUNCTION", 941 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 942 &target->where); 943 return false; 944 } 945 946 if (attr1.pointer && !attr2.pointer && !attr2.target) 947 { 948 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER " 949 "or a TARGET", gfc_current_intrinsic_arg[1]->name, 950 gfc_current_intrinsic, &target->where); 951 return false; 952 } 953 954 /* F2008, C1242. */ 955 if (attr1.pointer && gfc_is_coindexed (target)) 956 { 957 gfc_error ("%qs argument of %qs intrinsic at %L shall not be " 958 "coindexed", gfc_current_intrinsic_arg[1]->name, 959 gfc_current_intrinsic, &target->where); 960 return false; 961 } 962 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; 968 if (target->rank > 0) 969 { 970 for (i = 0; i < target->rank; i++) 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 " 974 "be the target of a pointer", 975 &target->where); 976 t = false; 977 break; 978 } 979 } 980 return t; 981 982null_arg: 983 984 gfc_error ("NULL pointer at %L is not permitted as actual argument " 985 "of %qs intrinsic function", where, gfc_current_intrinsic); 986 return false; 987 988} 989 990 991bool 992gfc_check_atan_2 (gfc_expr *y, gfc_expr *x) 993{ 994 /* gfc_notify_std would be a waste of time as the return value 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) 998 return false; 999 1000 return gfc_check_atan2 (y, x); 1001} 1002 1003 1004bool 1005gfc_check_atan2 (gfc_expr *y, gfc_expr *x) 1006{ 1007 if (!type_check (y, 0, BT_REAL)) 1008 return false; 1009 if (!same_type_check (y, 0, x, 1)) 1010 return false; 1011 1012 return true; 1013} 1014 1015 1016static bool 1017gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no, 1018 gfc_expr *stat, int stat_no) 1019{ 1020 if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no)) 1021 return false; 1022 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); 1030 return false; 1031 } 1032 1033 if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom)) 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); 1037 return false; 1038 } 1039 1040 if (atom->ts.type != value->ts.type) 1041 { 1042 gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall have the same " 1043 "type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name, 1044 gfc_current_intrinsic, &value->where, 1045 gfc_current_intrinsic_arg[atom_no]->name, &atom->where); 1046 return false; 1047 } 1048 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 1065 return true; 1066} 1067 1068 1069bool 1070gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) 1071{ 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 1077 if (!gfc_check_vardef_context (atom, false, false, false, NULL)) 1078 { 1079 gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " 1080 "definable", gfc_current_intrinsic, &atom->where); 1081 return false; 1082 } 1083 1084 return gfc_check_atomic (atom, 0, value, 1, stat, 2); 1085} 1086 1087 1088bool 1089gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) 1090{ 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; 1110 1111 if (!gfc_check_vardef_context (value, false, false, false, NULL)) 1112 { 1113 gfc_error ("VALUE argument of the %s intrinsic function at %L shall be " 1114 "definable", gfc_current_intrinsic, &value->where); 1115 return false; 1116 } 1117 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 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 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; 1255} 1256 1257 1258/* BESJN and BESYN functions. */ 1259 1260bool 1261gfc_check_besn (gfc_expr *n, gfc_expr *x) 1262{ 1263 if (!type_check (n, 0, BT_INTEGER)) 1264 return false; 1265 if (n->expr_type == EXPR_CONSTANT) 1266 { 1267 int i; 1268 gfc_extract_int (n, &i); 1269 if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument " 1270 "N at %L", &n->where)) 1271 return false; 1272 } 1273 1274 if (!type_check (x, 1, BT_REAL)) 1275 return false; 1276 1277 return true; 1278} 1279 1280 1281/* Transformational version of the Bessel JN and YN functions. */ 1282 1283bool 1284gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x) 1285{ 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; 1304 1305 return true; 1306} 1307 1308 1309bool 1310gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) 1311{ 1312 if (!type_check (i, 0, BT_INTEGER)) 1313 return false; 1314 1315 if (!type_check (j, 1, BT_INTEGER)) 1316 return false; 1317 1318 return true; 1319} 1320 1321 1322bool 1323gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) 1324{ 1325 if (!type_check (i, 0, BT_INTEGER)) 1326 return false; 1327 1328 if (!type_check (pos, 1, BT_INTEGER)) 1329 return false; 1330 1331 if (!nonnegative_check ("pos", pos)) 1332 return false; 1333 1334 if (!less_than_bitsize1 ("i", i, "pos", pos, false)) 1335 return false; 1336 1337 return true; 1338} 1339 1340 1341bool 1342gfc_check_char (gfc_expr *i, gfc_expr *kind) 1343{ 1344 if (!type_check (i, 0, BT_INTEGER)) 1345 return false; 1346 if (!kind_check (kind, 1, BT_CHARACTER)) 1347 return false; 1348 1349 return true; 1350} 1351 1352 1353bool 1354gfc_check_chdir (gfc_expr *dir) 1355{ 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; 1360 1361 return true; 1362} 1363 1364 1365bool 1366gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) 1367{ 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; 1372 1373 if (status == NULL) 1374 return true; 1375 1376 if (!type_check (status, 1, BT_INTEGER)) 1377 return false; 1378 if (!scalar_check (status, 1)) 1379 return false; 1380 1381 return true; 1382} 1383 1384 1385bool 1386gfc_check_chmod (gfc_expr *name, gfc_expr *mode) 1387{ 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; 1392 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; 1397 1398 return true; 1399} 1400 1401 1402bool 1403gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) 1404{ 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; 1409 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; 1414 1415 if (status == NULL) 1416 return true; 1417 1418 if (!type_check (status, 2, BT_INTEGER)) 1419 return false; 1420 1421 if (!scalar_check (status, 2)) 1422 return false; 1423 1424 return true; 1425} 1426 1427 1428bool 1429gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) 1430{ 1431 if (!numeric_check (x, 0)) 1432 return false; 1433 1434 if (y != NULL) 1435 { 1436 if (!numeric_check (y, 1)) 1437 return false; 1438 1439 if (x->ts.type == BT_COMPLEX) 1440 { 1441 gfc_error ("%qs argument of %qs intrinsic at %L must not be " 1442 "present if %<x%> is COMPLEX", 1443 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 1444 &y->where); 1445 return false; 1446 } 1447 1448 if (y->ts.type == BT_COMPLEX) 1449 { 1450 gfc_error ("%qs argument of %qs intrinsic at %L must have a type " 1451 "of either REAL or INTEGER", 1452 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 1453 &y->where); 1454 return false; 1455 } 1456 1457 } 1458 1459 if (!kind_check (kind, 2, BT_COMPLEX)) 1460 return false; 1461 1462 if (!kind && warn_conversion 1463 && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind) 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 1469 && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind) 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); 1474 return true; 1475} 1476 1477 1478static bool 1479check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat, 1480 gfc_expr *errmsg, bool co_reduce) 1481{ 1482 if (!variable_check (a, 0, false)) 1483 return false; 1484 1485 if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with " 1486 "INTENT(INOUT)")) 1487 return false; 1488 1489 /* Fortran 2008, 12.5.2.4, paragraph 18. */ 1490 if (gfc_has_vector_subscript (a)) 1491 { 1492 gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic " 1493 "subroutine %s shall not have a vector subscript", 1494 &a->where, gfc_current_intrinsic); 1495 return false; 1496 } 1497 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 1505 if (image_idx != NULL) 1506 { 1507 if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER)) 1508 return false; 1509 if (!scalar_check (image_idx, co_reduce ? 2 : 1)) 1510 return false; 1511 } 1512 1513 if (stat != NULL) 1514 { 1515 if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER)) 1516 return false; 1517 if (!scalar_check (stat, co_reduce ? 3 : 2)) 1518 return false; 1519 if (!variable_check (stat, co_reduce ? 3 : 2, false)) 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 { 1531 if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER)) 1532 return false; 1533 if (!scalar_check (errmsg, co_reduce ? 4 : 3)) 1534 return false; 1535 if (!variable_check (errmsg, co_reduce ? 4 : 3, false)) 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 1545 if (flag_coarray == GFC_FCOARRAY_NONE) 1546 { 1547 gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", 1548 &a->where); 1549 return false; 1550 } 1551 1552 return true; 1553} 1554 1555 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 { 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; 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; 1576 gfc_formal_arglist *formal; 1577 gfc_symbol *sym; 1578 1579 if (a->ts.type == BT_CLASS) 1580 { 1581 gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", 1582 &a->where); 1583 return false; 1584 } 1585 1586 if (gfc_expr_attr (a).alloc_comp) 1587 { 1588 gfc_error ("Support for the A argument at %L with allocatable components" 1589 " is not yet implemented", &a->where); 1590 return false; 1591 } 1592 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 1599 attr = gfc_expr_attr (op); 1600 if (!attr.pure || !attr.function) 1601 { 1602 gfc_error ("OPERATOR argument at %L must be a PURE function", 1603 &op->where); 1604 return false; 1605 } 1606 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 } 1616 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; 1624 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 { 1639 gfc_error_1 ("A argument at %L has type %s but the function passed as " 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 { 1719 gfc_error_1 ("The character length of the A argument at %L and of the " 1720 "arguments of the OPERATOR at %L shall be the same", 1721 &a->where, &op->where); 1722 return false; 1723 } 1724 if (actual_size && result_size && actual_size != result_size) 1725 { 1726 gfc_error_1 ("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); 1729 return false; 1730 } 1731 } 1732 1733 return true; 1734} 1735 1736 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 { 1744 gfc_error_1 ("'%s' argument of '%s' 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); 1748 return false; 1749 } 1750 return check_co_collective (a, result_image, stat, errmsg, false); 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; 1760 return check_co_collective (a, result_image, stat, errmsg, false); 1761} 1762 1763 1764bool 1765gfc_check_complex (gfc_expr *x, gfc_expr *y) 1766{ 1767 if (!int_or_real_check (x, 0)) 1768 return false; 1769 if (!scalar_check (x, 0)) 1770 return false; 1771 1772 if (!int_or_real_check (y, 1)) 1773 return false; 1774 if (!scalar_check (y, 1)) 1775 return false; 1776 1777 return true; 1778} 1779 1780 1781bool 1782gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) 1783{ 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; 1792 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 1793 "with KIND argument at %L", 1794 gfc_current_intrinsic, &kind->where)) 1795 return false; 1796 1797 return true; 1798} 1799 1800 1801bool 1802gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) 1803{ 1804 if (!array_check (array, 0)) 1805 return false; 1806 1807 if (!type_check (shift, 1, BT_INTEGER)) 1808 return false; 1809 1810 if (!dim_check (dim, 2, true)) 1811 return false; 1812 1813 if (!dim_rank_check (dim, array, false)) 1814 return false; 1815 1816 if (array->rank == 1 || shift->rank == 0) 1817 { 1818 if (!scalar_check (shift, 1)) 1819 return false; 1820 } 1821 else if (shift->rank == array->rank - 1) 1822 { 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 { 1839 gfc_error ("%qs argument of %qs intrinsic at %L has " 1840 "invalid shape in dimension %d (%ld/%ld)", 1841 gfc_current_intrinsic_arg[1]->name, 1842 gfc_current_intrinsic, &shift->where, i + 1, 1843 mpz_get_si (array->shape[i]), 1844 mpz_get_si (shift->shape[j])); 1845 return false; 1846 } 1847 1848 j += 1; 1849 } 1850 } 1851 } 1852 else 1853 { 1854 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " 1855 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, 1856 gfc_current_intrinsic, &shift->where, array->rank - 1); 1857 return false; 1858 } 1859 1860 return true; 1861} 1862 1863 1864bool 1865gfc_check_ctime (gfc_expr *time) 1866{ 1867 if (!scalar_check (time, 0)) 1868 return false; 1869 1870 if (!type_check (time, 0, BT_INTEGER)) 1871 return false; 1872 1873 return true; 1874} 1875 1876 1877bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x) 1878{ 1879 if (!double_check (y, 0) || !double_check (x, 1)) 1880 return false; 1881 1882 return true; 1883} 1884 1885bool 1886gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) 1887{ 1888 if (!numeric_check (x, 0)) 1889 return false; 1890 1891 if (y != NULL) 1892 { 1893 if (!numeric_check (y, 1)) 1894 return false; 1895 1896 if (x->ts.type == BT_COMPLEX) 1897 { 1898 gfc_error ("%qs argument of %qs intrinsic at %L must not be " 1899 "present if %<x%> is COMPLEX", 1900 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 1901 &y->where); 1902 return false; 1903 } 1904 1905 if (y->ts.type == BT_COMPLEX) 1906 { 1907 gfc_error ("%qs argument of %qs intrinsic at %L must have a type " 1908 "of either REAL or INTEGER", 1909 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 1910 &y->where); 1911 return false; 1912 } 1913 } 1914 1915 return true; 1916} 1917 1918 1919bool 1920gfc_check_dble (gfc_expr *x) 1921{ 1922 if (!numeric_check (x, 0)) 1923 return false; 1924 1925 return true; 1926} 1927 1928 1929bool 1930gfc_check_digits (gfc_expr *x) 1931{ 1932 if (!int_or_real_check (x, 0)) 1933 return false; 1934 1935 return true; 1936} 1937 1938 1939bool 1940gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) 1941{ 1942 switch (vector_a->ts.type) 1943 { 1944 case BT_LOGICAL: 1945 if (!type_check (vector_b, 1, BT_LOGICAL)) 1946 return false; 1947 break; 1948 1949 case BT_INTEGER: 1950 case BT_REAL: 1951 case BT_COMPLEX: 1952 if (!numeric_check (vector_b, 1)) 1953 return false; 1954 break; 1955 1956 default: 1957 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " 1958 "or LOGICAL", gfc_current_intrinsic_arg[0]->name, 1959 gfc_current_intrinsic, &vector_a->where); 1960 return false; 1961 } 1962 1963 if (!rank_check (vector_a, 0, 1)) 1964 return false; 1965 1966 if (!rank_check (vector_b, 1, 1)) 1967 return false; 1968 1969 if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) 1970 { 1971 gfc_error ("Different shape for arguments %qs and %qs at %L for " 1972 "intrinsic %<dot_product%>", 1973 gfc_current_intrinsic_arg[0]->name, 1974 gfc_current_intrinsic_arg[1]->name, &vector_a->where); 1975 return false; 1976 } 1977 1978 return true; 1979} 1980 1981 1982bool 1983gfc_check_dprod (gfc_expr *x, gfc_expr *y) 1984{ 1985 if (!type_check (x, 0, BT_REAL) 1986 || !type_check (y, 1, BT_REAL)) 1987 return false; 1988 1989 if (x->ts.kind != gfc_default_real_kind) 1990 { 1991 gfc_error ("%qs argument of %qs intrinsic at %L must be default " 1992 "real", gfc_current_intrinsic_arg[0]->name, 1993 gfc_current_intrinsic, &x->where); 1994 return false; 1995 } 1996 1997 if (y->ts.kind != gfc_default_real_kind) 1998 { 1999 gfc_error ("%qs argument of %qs intrinsic at %L must be default " 2000 "real", gfc_current_intrinsic_arg[1]->name, 2001 gfc_current_intrinsic, &y->where); 2002 return false; 2003 } 2004 2005 return true; 2006} 2007 2008 2009bool 2010gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) 2011{ 2012 if (!type_check (i, 0, BT_INTEGER)) 2013 return false; 2014 2015 if (!type_check (j, 1, BT_INTEGER)) 2016 return false; 2017 2018 if (i->is_boz && j->is_boz) 2019 { 2020 gfc_error_1 ("'I' at %L and 'J' at %L cannot both be BOZ literal " 2021 "constants", &i->where, &j->where); 2022 return false; 2023 } 2024 2025 if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1)) 2026 return false; 2027 2028 if (!type_check (shift, 2, BT_INTEGER)) 2029 return false; 2030 2031 if (!nonnegative_check ("SHIFT", shift)) 2032 return false; 2033 2034 if (i->is_boz) 2035 { 2036 if (!less_than_bitsize1 ("J", j, "SHIFT", shift, true)) 2037 return false; 2038 i->ts.kind = j->ts.kind; 2039 } 2040 else 2041 { 2042 if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) 2043 return false; 2044 j->ts.kind = i->ts.kind; 2045 } 2046 2047 return true; 2048} 2049 2050 2051bool 2052gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, 2053 gfc_expr *dim) 2054{ 2055 if (!array_check (array, 0)) 2056 return false; 2057 2058 if (!type_check (shift, 1, BT_INTEGER)) 2059 return false; 2060 2061 if (!dim_check (dim, 3, true)) 2062 return false; 2063 2064 if (!dim_rank_check (dim, array, false)) 2065 return false; 2066 2067 if (array->rank == 1 || shift->rank == 0) 2068 { 2069 if (!scalar_check (shift, 1)) 2070 return false; 2071 } 2072 else if (shift->rank == array->rank - 1) 2073 { 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 { 2090 gfc_error ("%qs argument of %qs intrinsic at %L has " 2091 "invalid shape in dimension %d (%ld/%ld)", 2092 gfc_current_intrinsic_arg[1]->name, 2093 gfc_current_intrinsic, &shift->where, i + 1, 2094 mpz_get_si (array->shape[i]), 2095 mpz_get_si (shift->shape[j])); 2096 return false; 2097 } 2098 2099 j += 1; 2100 } 2101 } 2102 } 2103 else 2104 { 2105 gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " 2106 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, 2107 gfc_current_intrinsic, &shift->where, array->rank - 1); 2108 return false; 2109 } 2110 2111 if (boundary != NULL) 2112 { 2113 if (!same_type_check (array, 0, boundary, 2)) 2114 return false; 2115 2116 if (array->rank == 1 || boundary->rank == 0) 2117 { 2118 if (!scalar_check (boundary, 2)) 2119 return false; 2120 } 2121 else if (boundary->rank == array->rank - 1) 2122 { 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; 2130 } 2131 else 2132 { 2133 gfc_error ("%qs argument of intrinsic %qs at %L of must have " 2134 "rank %d or be a scalar", 2135 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 2136 &shift->where, array->rank - 1); 2137 return false; 2138 } 2139 } 2140 2141 return true; 2142} 2143 2144bool 2145gfc_check_float (gfc_expr *a) 2146{ 2147 if (!type_check (a, 0, BT_INTEGER)) 2148 return false; 2149 2150 if ((a->ts.kind != gfc_default_integer_kind) 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; 2155 2156 return true; 2157} 2158 2159/* A single complex argument. */ 2160 2161bool 2162gfc_check_fn_c (gfc_expr *a) 2163{ 2164 if (!type_check (a, 0, BT_COMPLEX)) 2165 return false; 2166 2167 return true; 2168} 2169 2170/* A single real argument. */ 2171 2172bool 2173gfc_check_fn_r (gfc_expr *a) 2174{ 2175 if (!type_check (a, 0, BT_REAL)) 2176 return false; 2177 2178 return true; 2179} 2180 2181/* A single double argument. */ 2182 2183bool 2184gfc_check_fn_d (gfc_expr *a) 2185{ 2186 if (!double_check (a, 0)) 2187 return false; 2188 2189 return true; 2190} 2191 2192/* A single real or complex argument. */ 2193 2194bool 2195gfc_check_fn_rc (gfc_expr *a) 2196{ 2197 if (!real_or_complex_check (a, 0)) 2198 return false; 2199 2200 return true; 2201} 2202 2203 2204bool 2205gfc_check_fn_rc2008 (gfc_expr *a) 2206{ 2207 if (!real_or_complex_check (a, 0)) 2208 return false; 2209 2210 if (a->ts.type == BT_COMPLEX 2211 && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs " 2212 "of %qs intrinsic at %L", 2213 gfc_current_intrinsic_arg[0]->name, 2214 gfc_current_intrinsic, &a->where)) 2215 return false; 2216 2217 return true; 2218} 2219 2220 2221bool 2222gfc_check_fnum (gfc_expr *unit) 2223{ 2224 if (!type_check (unit, 0, BT_INTEGER)) 2225 return false; 2226 2227 if (!scalar_check (unit, 0)) 2228 return false; 2229 2230 return true; 2231} 2232 2233 2234bool 2235gfc_check_huge (gfc_expr *x) 2236{ 2237 if (!int_or_real_check (x, 0)) 2238 return false; 2239 2240 return true; 2241} 2242 2243 2244bool 2245gfc_check_hypot (gfc_expr *x, gfc_expr *y) 2246{ 2247 if (!type_check (x, 0, BT_REAL)) 2248 return false; 2249 if (!same_type_check (x, 0, y, 1)) 2250 return false; 2251 2252 return true; 2253} 2254 2255 2256/* Check that the single argument is an integer. */ 2257 2258bool 2259gfc_check_i (gfc_expr *i) 2260{ 2261 if (!type_check (i, 0, BT_INTEGER)) 2262 return false; 2263 2264 return true; 2265} 2266 2267 2268bool 2269gfc_check_iand (gfc_expr *i, gfc_expr *j) 2270{ 2271 if (!type_check (i, 0, BT_INTEGER)) 2272 return false; 2273 2274 if (!type_check (j, 1, BT_INTEGER)) 2275 return false; 2276 2277 if (i->ts.kind != j->ts.kind) 2278 { 2279 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 2280 &i->where)) 2281 return false; 2282 } 2283 2284 return true; 2285} 2286 2287 2288bool 2289gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) 2290{ 2291 if (!type_check (i, 0, BT_INTEGER)) 2292 return false; 2293 2294 if (!type_check (pos, 1, BT_INTEGER)) 2295 return false; 2296 2297 if (!type_check (len, 2, BT_INTEGER)) 2298 return false; 2299 2300 if (!nonnegative_check ("pos", pos)) 2301 return false; 2302 2303 if (!nonnegative_check ("len", len)) 2304 return false; 2305 2306 if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len)) 2307 return false; 2308 2309 return true; 2310} 2311 2312 2313bool 2314gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) 2315{ 2316 int i; 2317 2318 if (!type_check (c, 0, BT_CHARACTER)) 2319 return false; 2320 2321 if (!kind_check (kind, 1, BT_INTEGER)) 2322 return false; 2323 2324 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 2325 "with KIND argument at %L", 2326 gfc_current_intrinsic, &kind->where)) 2327 return false; 2328 2329 if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING) 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) 2343 { 2344 /* Check that the argument is length one. Non-constant lengths 2345 can't be checked here, so assume they are ok. */ 2346 if (c->ts.u.cl && c->ts.u.cl->length) 2347 { 2348 /* If we already have a length for this expression then use it. */ 2349 if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT) 2350 return true; 2351 i = mpz_get_si (c->ts.u.cl->length->value.integer); 2352 } 2353 else 2354 return true; 2355 } 2356 else 2357 { 2358 start = ref->u.ss.start; 2359 end = ref->u.ss.end; 2360 2361 gcc_assert (start); 2362 if (end == NULL || end->expr_type != EXPR_CONSTANT 2363 || start->expr_type != EXPR_CONSTANT) 2364 return true; 2365 2366 i = mpz_get_si (end->value.integer) + 1 2367 - mpz_get_si (start->value.integer); 2368 } 2369 } 2370 else 2371 return true; 2372 2373 if (i != 1) 2374 { 2375 gfc_error ("Argument of %s at %L must be of length one", 2376 gfc_current_intrinsic, &c->where); 2377 return false; 2378 } 2379 2380 return true; 2381} 2382 2383 2384bool 2385gfc_check_idnint (gfc_expr *a) 2386{ 2387 if (!double_check (a, 0)) 2388 return false; 2389 2390 return true; 2391} 2392 2393 2394bool 2395gfc_check_ieor (gfc_expr *i, gfc_expr *j) 2396{ 2397 if (!type_check (i, 0, BT_INTEGER)) 2398 return false; 2399 2400 if (!type_check (j, 1, BT_INTEGER)) 2401 return false; 2402 2403 if (i->ts.kind != j->ts.kind) 2404 { 2405 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 2406 &i->where)) 2407 return false; 2408 } 2409 2410 return true; 2411} 2412 2413 2414bool 2415gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, 2416 gfc_expr *kind) 2417{ 2418 if (!type_check (string, 0, BT_CHARACTER) 2419 || !type_check (substring, 1, BT_CHARACTER)) 2420 return false; 2421 2422 if (back != NULL && !type_check (back, 2, BT_LOGICAL)) 2423 return false; 2424 2425 if (!kind_check (kind, 3, BT_INTEGER)) 2426 return false; 2427 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 2428 "with KIND argument at %L", 2429 gfc_current_intrinsic, &kind->where)) 2430 return false; 2431 2432 if (string->ts.kind != substring->ts.kind) 2433 { 2434 gfc_error ("%qs argument of %qs intrinsic at %L must be the same " 2435 "kind as %qs", gfc_current_intrinsic_arg[1]->name, 2436 gfc_current_intrinsic, &substring->where, 2437 gfc_current_intrinsic_arg[0]->name); 2438 return false; 2439 } 2440 2441 return true; 2442} 2443 2444 2445bool 2446gfc_check_int (gfc_expr *x, gfc_expr *kind) 2447{ 2448 if (!numeric_check (x, 0)) 2449 return false; 2450 2451 if (!kind_check (kind, 1, BT_INTEGER)) 2452 return false; 2453 2454 return true; 2455} 2456 2457 2458bool 2459gfc_check_intconv (gfc_expr *x) 2460{ 2461 if (!numeric_check (x, 0)) 2462 return false; 2463 2464 return true; 2465} 2466 2467 2468bool 2469gfc_check_ior (gfc_expr *i, gfc_expr *j) 2470{ 2471 if (!type_check (i, 0, BT_INTEGER)) 2472 return false; 2473 2474 if (!type_check (j, 1, BT_INTEGER)) 2475 return false; 2476 2477 if (i->ts.kind != j->ts.kind) 2478 { 2479 if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 2480 &i->where)) 2481 return false; 2482 } 2483 2484 return true; 2485} 2486 2487 2488bool 2489gfc_check_ishft (gfc_expr *i, gfc_expr *shift) 2490{ 2491 if (!type_check (i, 0, BT_INTEGER) 2492 || !type_check (shift, 1, BT_INTEGER)) 2493 return false; 2494 2495 if (!less_than_bitsize1 ("I", i, NULL, shift, true)) 2496 return false; 2497 2498 return true; 2499} 2500 2501 2502bool 2503gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) 2504{ 2505 if (!type_check (i, 0, BT_INTEGER) 2506 || !type_check (shift, 1, BT_INTEGER)) 2507 return false; 2508 2509 if (size != NULL) 2510 { 2511 int i2, i3; 2512 2513 if (!type_check (size, 2, BT_INTEGER)) 2514 return false; 2515 2516 if (!less_than_bitsize1 ("I", i, "SIZE", size, true)) 2517 return false; 2518 2519 if (size->expr_type == EXPR_CONSTANT) 2520 { 2521 gfc_extract_int (size, &i3); 2522 if (i3 <= 0) 2523 { 2524 gfc_error ("SIZE at %L must be positive", &size->where); 2525 return false; 2526 } 2527 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 { 2536 gfc_error_1 ("The absolute value of SHIFT at %L must be less " 2537 "than or equal to SIZE at %L", &shift->where, 2538 &size->where); 2539 return false; 2540 } 2541 } 2542 } 2543 } 2544 else if (!less_than_bitsize1 ("I", i, NULL, shift, true)) 2545 return false; 2546 2547 return true; 2548} 2549 2550 2551bool 2552gfc_check_kill (gfc_expr *pid, gfc_expr *sig) 2553{ 2554 if (!type_check (pid, 0, BT_INTEGER)) 2555 return false; 2556 2557 if (!type_check (sig, 1, BT_INTEGER)) 2558 return false; 2559 2560 return true; 2561} 2562 2563 2564bool 2565gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) 2566{ 2567 if (!type_check (pid, 0, BT_INTEGER)) 2568 return false; 2569 2570 if (!scalar_check (pid, 0)) 2571 return false; 2572 2573 if (!type_check (sig, 1, BT_INTEGER)) 2574 return false; 2575 2576 if (!scalar_check (sig, 1)) 2577 return false; 2578 2579 if (status == NULL) 2580 return true; 2581 2582 if (!type_check (status, 2, BT_INTEGER)) 2583 return false; 2584 2585 if (!scalar_check (status, 2)) 2586 return false; 2587 2588 return true; 2589} 2590 2591 2592bool 2593gfc_check_kind (gfc_expr *x) 2594{ 2595 if (x->ts.type == BT_DERIVED || x->ts.type == BT_CLASS) 2596 { 2597 gfc_error ("%qs argument of %qs intrinsic at %L must be of " 2598 "intrinsic type", gfc_current_intrinsic_arg[0]->name, 2599 gfc_current_intrinsic, &x->where); 2600 return false; 2601 } 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 } 2609 2610 return true; 2611} 2612 2613 2614bool 2615gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 2616{ 2617 if (!array_check (array, 0)) 2618 return false; 2619 2620 if (!dim_check (dim, 1, false)) 2621 return false; 2622 2623 if (!dim_rank_check (dim, array, 1)) 2624 return false; 2625 2626 if (!kind_check (kind, 2, BT_INTEGER)) 2627 return false; 2628 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 2629 "with KIND argument at %L", 2630 gfc_current_intrinsic, &kind->where)) 2631 return false; 2632 2633 return true; 2634} 2635 2636 2637bool 2638gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) 2639{ 2640 if (flag_coarray == GFC_FCOARRAY_NONE) 2641 { 2642 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 2643 return false; 2644 } 2645 2646 if (!coarray_check (coarray, 0)) 2647 return false; 2648 2649 if (dim != NULL) 2650 { 2651 if (!dim_check (dim, 1, false)) 2652 return false; 2653 2654 if (!dim_corank_check (dim, coarray)) 2655 return false; 2656 } 2657 2658 if (!kind_check (kind, 2, BT_INTEGER)) 2659 return false; 2660 2661 return true; 2662} 2663 2664 2665bool 2666gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) 2667{ 2668 if (!type_check (s, 0, BT_CHARACTER)) 2669 return false; 2670 2671 if (!kind_check (kind, 1, BT_INTEGER)) 2672 return false; 2673 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 2674 "with KIND argument at %L", 2675 gfc_current_intrinsic, &kind->where)) 2676 return false; 2677 2678 return true; 2679} 2680 2681 2682bool 2683gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b) 2684{ 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; 2689 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; 2694 2695 return true; 2696} 2697 2698 2699bool 2700gfc_check_link (gfc_expr *path1, gfc_expr *path2) 2701{ 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; 2706 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; 2711 2712 return true; 2713} 2714 2715 2716bool 2717gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) 2718{ 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; 2723 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; 2728 2729 if (status == NULL) 2730 return true; 2731 2732 if (!type_check (status, 2, BT_INTEGER)) 2733 return false; 2734 2735 if (!scalar_check (status, 2)) 2736 return false; 2737 2738 return true; 2739} 2740 2741 2742bool 2743gfc_check_loc (gfc_expr *expr) 2744{ 2745 return variable_check (expr, 0, true); 2746} 2747 2748 2749bool 2750gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) 2751{ 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; 2756 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; 2761 2762 return true; 2763} 2764 2765 2766bool 2767gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) 2768{ 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; 2773 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; 2778 2779 if (status == NULL) 2780 return true; 2781 2782 if (!type_check (status, 2, BT_INTEGER)) 2783 return false; 2784 2785 if (!scalar_check (status, 2)) 2786 return false; 2787 2788 return true; 2789} 2790 2791 2792bool 2793gfc_check_logical (gfc_expr *a, gfc_expr *kind) 2794{ 2795 if (!type_check (a, 0, BT_LOGICAL)) 2796 return false; 2797 if (!kind_check (kind, 1, BT_LOGICAL)) 2798 return false; 2799 2800 return true; 2801} 2802 2803 2804/* Min/max family. */ 2805 2806static bool 2807min_max_args (gfc_actual_arglist *args) 2808{ 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) 2814 { 2815 gfc_error ("Intrinsic %qs at %L must have at least two arguments", 2816 gfc_current_intrinsic, gfc_current_intrinsic_where); 2817 return false; 2818 } 2819 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 { 2863 gfc_error ("Missing %qs argument to the %s intrinsic at %L", 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 2875 return true; 2876 2877duplicate: 2878 gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name, 2879 &arg->expr->where, gfc_current_intrinsic); 2880 return false; 2881 2882unknown: 2883 gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name, 2884 &arg->expr->where, gfc_current_intrinsic); 2885 return false; 2886} 2887 2888 2889static bool 2890check_rest (bt type, int kind, gfc_actual_arglist *arglist) 2891{ 2892 gfc_actual_arglist *arg, *tmp; 2893 gfc_expr *x; 2894 int m, n; 2895 2896 if (!min_max_args (arglist)) 2897 return false; 2898 2899 for (arg = arglist, n=1; arg; arg = arg->next, n++) 2900 { 2901 x = arg->expr; 2902 if (x->ts.type != type || x->ts.kind != kind) 2903 { 2904 if (x->ts.type == type) 2905 { 2906 if (!gfc_notify_std (GFC_STD_GNU, "Different type " 2907 "kinds at %L", &x->where)) 2908 return false; 2909 } 2910 else 2911 { 2912 gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be " 2913 "%s(%d)", n, gfc_current_intrinsic, &x->where, 2914 gfc_basic_typename (type), kind); 2915 return false; 2916 } 2917 } 2918 2919 for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) 2920 if (!gfc_check_conformance (tmp->expr, x, 2921 "arguments 'a%d' and 'a%d' for " 2922 "intrinsic '%s'", m, n, 2923 gfc_current_intrinsic)) 2924 return false; 2925 } 2926 2927 return true; 2928} 2929 2930 2931bool 2932gfc_check_min_max (gfc_actual_arglist *arg) 2933{ 2934 gfc_expr *x; 2935 2936 if (!min_max_args (arg)) 2937 return false; 2938 2939 x = arg->expr; 2940 2941 if (x->ts.type == BT_CHARACTER) 2942 { 2943 if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 2944 "with CHARACTER argument at %L", 2945 gfc_current_intrinsic, &x->where)) 2946 return false; 2947 } 2948 else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) 2949 { 2950 gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, " 2951 "REAL or CHARACTER", gfc_current_intrinsic, &x->where); 2952 return false; 2953 } 2954 2955 return check_rest (x->ts.type, x->ts.kind, arg); 2956} 2957 2958 2959bool 2960gfc_check_min_max_integer (gfc_actual_arglist *arg) 2961{ 2962 return check_rest (BT_INTEGER, gfc_default_integer_kind, arg); 2963} 2964 2965 2966bool 2967gfc_check_min_max_real (gfc_actual_arglist *arg) 2968{ 2969 return check_rest (BT_REAL, gfc_default_real_kind, arg); 2970} 2971 2972 2973bool 2974gfc_check_min_max_double (gfc_actual_arglist *arg) 2975{ 2976 return check_rest (BT_REAL, gfc_default_double_kind, arg); 2977} 2978 2979 2980/* End of min/max family. */ 2981 2982bool 2983gfc_check_malloc (gfc_expr *size) 2984{ 2985 if (!type_check (size, 0, BT_INTEGER)) 2986 return false; 2987 2988 if (!scalar_check (size, 0)) 2989 return false; 2990 2991 return true; 2992} 2993 2994 2995bool 2996gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) 2997{ 2998 if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) 2999 { 3000 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " 3001 "or LOGICAL", gfc_current_intrinsic_arg[0]->name, 3002 gfc_current_intrinsic, &matrix_a->where); 3003 return false; 3004 } 3005 3006 if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) 3007 { 3008 gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " 3009 "or LOGICAL", gfc_current_intrinsic_arg[1]->name, 3010 gfc_current_intrinsic, &matrix_b->where); 3011 return false; 3012 } 3013 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 { 3017 gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)", 3018 gfc_current_intrinsic, &matrix_a->where, 3019 gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); 3020 return false; 3021 } 3022 3023 switch (matrix_a->rank) 3024 { 3025 case 1: 3026 if (!rank_check (matrix_b, 1, 2)) 3027 return false; 3028 /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */ 3029 if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0)) 3030 { 3031 gfc_error ("Different shape on dimension 1 for arguments %qs " 3032 "and %qs at %L for intrinsic matmul", 3033 gfc_current_intrinsic_arg[0]->name, 3034 gfc_current_intrinsic_arg[1]->name, &matrix_a->where); 3035 return false; 3036 } 3037 break; 3038 3039 case 2: 3040 if (matrix_b->rank != 2) 3041 { 3042 if (!rank_check (matrix_b, 1, 1)) 3043 return false; 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). */ 3048 if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0)) 3049 { 3050 gfc_error ("Different shape on dimension 2 for argument %qs and " 3051 "dimension 1 for argument %qs at %L for intrinsic " 3052 "matmul", gfc_current_intrinsic_arg[0]->name, 3053 gfc_current_intrinsic_arg[1]->name, &matrix_a->where); 3054 return false; 3055 } 3056 break; 3057 3058 default: 3059 gfc_error ("%qs argument of %qs intrinsic at %L must be of rank " 3060 "1 or 2", gfc_current_intrinsic_arg[0]->name, 3061 gfc_current_intrinsic, &matrix_a->where); 3062 return false; 3063 } 3064 3065 return true; 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 3073 Arg #2 Arg #3 3074 NULL NULL 3075 DIM NULL 3076 MASK NULL 3077 NULL MASK minloc(array, mask=m) 3078 DIM MASK 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. */ 3082 3083bool 3084gfc_check_minloc_maxloc (gfc_actual_arglist *ap) 3085{ 3086 gfc_expr *a, *m, *d; 3087 3088 a = ap->expr; 3089 if (!int_or_real_check (a, 0) || !array_check (a, 0)) 3090 return false; 3091 3092 d = ap->next->expr; 3093 m = ap->next->next->expr; 3094 3095 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL 3096 && ap->next->name == NULL) 3097 { 3098 m = d; 3099 d = NULL; 3100 ap->next->expr = NULL; 3101 ap->next->next->expr = m; 3102 } 3103 3104 if (!dim_check (d, 1, false)) 3105 return false; 3106 3107 if (!dim_rank_check (d, a, 0)) 3108 return false; 3109 3110 if (m != NULL && !type_check (m, 2, BT_LOGICAL)) 3111 return false; 3112 3113 if (m != NULL 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; 3120 3121 return true; 3122} 3123 3124 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 3130 Arg #2 Arg #3 3131 NULL NULL 3132 DIM NULL 3133 MASK NULL 3134 NULL MASK minval(array, mask=m) 3135 DIM MASK 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 3140static bool 3141check_reduction (gfc_actual_arglist *ap) 3142{ 3143 gfc_expr *a, *m, *d; 3144 3145 a = ap->expr; 3146 d = ap->next->expr; 3147 m = ap->next->next->expr; 3148 3149 if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL 3150 && ap->next->name == NULL) 3151 { 3152 m = d; 3153 d = NULL; 3154 ap->next->expr = NULL; 3155 ap->next->next->expr = m; 3156 } 3157 3158 if (!dim_check (d, 1, false)) 3159 return false; 3160 3161 if (!dim_rank_check (d, a, 0)) 3162 return false; 3163 3164 if (m != NULL && !type_check (m, 2, BT_LOGICAL)) 3165 return false; 3166 3167 if (m != NULL 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; 3174 3175 return true; 3176} 3177 3178 3179bool 3180gfc_check_minval_maxval (gfc_actual_arglist *ap) 3181{ 3182 if (!int_or_real_check (ap->expr, 0) 3183 || !array_check (ap->expr, 0)) 3184 return false; 3185 3186 return check_reduction (ap); 3187} 3188 3189 3190bool 3191gfc_check_product_sum (gfc_actual_arglist *ap) 3192{ 3193 if (!numeric_check (ap->expr, 0) 3194 || !array_check (ap->expr, 0)) 3195 return false; 3196 3197 return check_reduction (ap); 3198} 3199 3200 3201/* For IANY, IALL and IPARITY. */ 3202 3203bool 3204gfc_check_mask (gfc_expr *i, gfc_expr *kind) 3205{ 3206 int k; 3207 3208 if (!type_check (i, 0, BT_INTEGER)) 3209 return false; 3210 3211 if (!nonnegative_check ("I", i)) 3212 return false; 3213 3214 if (!kind_check (kind, 1, BT_INTEGER)) 3215 return false; 3216 3217 if (kind) 3218 gfc_extract_int (kind, &k); 3219 else 3220 k = gfc_default_integer_kind; 3221 3222 if (!less_than_bitsizekind ("I", i, k)) 3223 return false; 3224 3225 return true; 3226} 3227 3228 3229bool 3230gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) 3231{ 3232 if (ap->expr->ts.type != BT_INTEGER) 3233 { 3234 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", 3235 gfc_current_intrinsic_arg[0]->name, 3236 gfc_current_intrinsic, &ap->expr->where); 3237 return false; 3238 } 3239 3240 if (!array_check (ap->expr, 0)) 3241 return false; 3242 3243 return check_reduction (ap); 3244} 3245 3246 3247bool 3248gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) 3249{ 3250 if (!same_type_check (tsource, 0, fsource, 1)) 3251 return false; 3252 3253 if (!type_check (mask, 2, BT_LOGICAL)) 3254 return false; 3255 3256 if (tsource->ts.type == BT_CHARACTER) 3257 return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic"); 3258 3259 return true; 3260} 3261 3262 3263bool 3264gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) 3265{ 3266 if (!type_check (i, 0, BT_INTEGER)) 3267 return false; 3268 3269 if (!type_check (j, 1, BT_INTEGER)) 3270 return false; 3271 3272 if (!type_check (mask, 2, BT_INTEGER)) 3273 return false; 3274 3275 if (!same_type_check (i, 0, j, 1)) 3276 return false; 3277 3278 if (!same_type_check (i, 0, mask, 2)) 3279 return false; 3280 3281 return true; 3282} 3283 3284 3285bool 3286gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) 3287{ 3288 if (!variable_check (from, 0, false)) 3289 return false; 3290 if (!allocatable_check (from, 0)) 3291 return false; 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); 3296 return false; 3297 } 3298 3299 if (!variable_check (to, 1, false)) 3300 return false; 3301 if (!allocatable_check (to, 1)) 3302 return false; 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); 3307 return false; 3308 } 3309 3310 if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) 3311 { 3312 gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " 3313 "polymorphic if FROM is polymorphic", 3314 &to->where); 3315 return false; 3316 } 3317 3318 if (!same_type_check (to, 1, from, 0)) 3319 return false; 3320 3321 if (to->rank != from->rank) 3322 { 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); 3326 return false; 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)); 3335 return false; 3336 } 3337 3338 /* CLASS arguments: Make sure the vtab of from is present. */ 3339 if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from)) 3340 gfc_find_vtab (&from->ts); 3341 3342 return true; 3343} 3344 3345 3346bool 3347gfc_check_nearest (gfc_expr *x, gfc_expr *s) 3348{ 3349 if (!type_check (x, 0, BT_REAL)) 3350 return false; 3351 3352 if (!type_check (s, 1, BT_REAL)) 3353 return false; 3354 3355 if (s->expr_type == EXPR_CONSTANT) 3356 { 3357 if (mpfr_sgn (s->value.real) == 0) 3358 { 3359 gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero", 3360 &s->where); 3361 return false; 3362 } 3363 } 3364 3365 return true; 3366} 3367 3368 3369bool 3370gfc_check_new_line (gfc_expr *a) 3371{ 3372 if (!type_check (a, 0, BT_CHARACTER)) 3373 return false; 3374 3375 return true; 3376} 3377 3378 3379bool 3380gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) 3381{ 3382 if (!type_check (array, 0, BT_REAL)) 3383 return false; 3384 3385 if (!array_check (array, 0)) 3386 return false; 3387 3388 if (!dim_rank_check (dim, array, false)) 3389 return false; 3390 3391 return true; 3392} 3393 3394bool 3395gfc_check_null (gfc_expr *mold) 3396{ 3397 symbol_attribute attr; 3398 3399 if (mold == NULL) 3400 return true; 3401 3402 if (!variable_check (mold, 0, true)) 3403 return false; 3404 3405 attr = gfc_variable_attr (mold, NULL); 3406 3407 if (!attr.pointer && !attr.proc_pointer && !attr.allocatable) 3408 { 3409 gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, " 3410 "ALLOCATABLE or procedure pointer", 3411 gfc_current_intrinsic_arg[0]->name, 3412 gfc_current_intrinsic, &mold->where); 3413 return false; 3414 } 3415 3416 if (attr.allocatable 3417 && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with " 3418 "allocatable MOLD at %L", &mold->where)) 3419 return false; 3420 3421 /* F2008, C1242. */ 3422 if (gfc_is_coindexed (mold)) 3423 { 3424 gfc_error ("%qs argument of %qs intrinsic at %L shall not be " 3425 "coindexed", gfc_current_intrinsic_arg[0]->name, 3426 gfc_current_intrinsic, &mold->where); 3427 return false; 3428 } 3429 3430 return true; 3431} 3432 3433 3434bool 3435gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 3436{ 3437 if (!array_check (array, 0)) 3438 return false; 3439 3440 if (!type_check (mask, 1, BT_LOGICAL)) 3441 return false; 3442 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; 3449 3450 if (vector != NULL) 3451 { 3452 mpz_t array_size, vector_size; 3453 bool have_array_size, have_vector_size; 3454 3455 if (!same_type_check (array, 0, vector, 2)) 3456 return false; 3457 3458 if (!rank_check (vector, 2, 1)) 3459 return false; 3460 3461 /* VECTOR requires at least as many elements as MASK 3462 has .TRUE. values. */ 3463 have_array_size = gfc_array_size(array, &array_size); 3464 have_vector_size = gfc_array_size(vector, &vector_size); 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 { 3475 gfc_constructor *mask_ctor; 3476 mask_ctor = gfc_constructor_first (mask->value.constructor); 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 3488 mask_ctor = gfc_constructor_next (mask_ctor); 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 { 3496 gfc_error ("%qs argument of %qs intrinsic at %L must " 3497 "provide at least as many elements as there " 3498 "are .TRUE. values in %qs (%ld/%d)", 3499 gfc_current_intrinsic_arg[2]->name, 3500 gfc_current_intrinsic, &vector->where, 3501 gfc_current_intrinsic_arg[1]->name, 3502 mpz_get_si (vector_size), mask_true_values); 3503 return false; 3504 } 3505 } 3506 3507 if (have_array_size) 3508 mpz_clear (array_size); 3509 if (have_vector_size) 3510 mpz_clear (vector_size); 3511 } 3512 3513 return true; 3514} 3515 3516 3517bool 3518gfc_check_parity (gfc_expr *mask, gfc_expr *dim) 3519{ 3520 if (!type_check (mask, 0, BT_LOGICAL)) 3521 return false; 3522 3523 if (!array_check (mask, 0)) 3524 return false; 3525 3526 if (!dim_rank_check (dim, mask, false)) 3527 return false; 3528 3529 return true; 3530} 3531 3532 3533bool 3534gfc_check_precision (gfc_expr *x) 3535{ 3536 if (!real_or_complex_check (x, 0)) 3537 return false; 3538 3539 return true; 3540} 3541 3542 3543bool 3544gfc_check_present (gfc_expr *a) 3545{ 3546 gfc_symbol *sym; 3547 3548 if (!variable_check (a, 0, true)) 3549 return false; 3550 3551 sym = a->symtree->n.sym; 3552 if (!sym->attr.dummy) 3553 { 3554 gfc_error ("%qs argument of %qs intrinsic at %L must be of a " 3555 "dummy variable", gfc_current_intrinsic_arg[0]->name, 3556 gfc_current_intrinsic, &a->where); 3557 return false; 3558 } 3559 3560 if (!sym->attr.optional) 3561 { 3562 gfc_error ("%qs argument of %qs intrinsic at %L must be of " 3563 "an OPTIONAL dummy variable", 3564 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 3565 &a->where); 3566 return false; 3567 } 3568 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... */ 3574 3575 if (a->ref != NULL 3576 && !(a->ref->next == NULL && a->ref->type == REF_ARRAY 3577 && (a->ref->u.ar.type == AR_FULL 3578 || (a->ref->u.ar.type == AR_ELEMENT 3579 && a->ref->u.ar.as->rank == 0)))) 3580 { 3581 gfc_error ("%qs argument of %qs intrinsic at %L must not be a " 3582 "subobject of %qs", gfc_current_intrinsic_arg[0]->name, 3583 gfc_current_intrinsic, &a->where, sym->name); 3584 return false; 3585 } 3586 3587 return true; 3588} 3589 3590 3591bool 3592gfc_check_radix (gfc_expr *x) 3593{ 3594 if (!int_or_real_check (x, 0)) 3595 return false; 3596 3597 return true; 3598} 3599 3600 3601bool 3602gfc_check_range (gfc_expr *x) 3603{ 3604 if (!numeric_check (x, 0)) 3605 return false; 3606 3607 return true; 3608} 3609 3610 3611bool 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 3619 /* Functions returning pointers are regarded as variable, cf. F2008, R602. */ 3620 if (a->expr_type == EXPR_FUNCTION) 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); 3631 return false; 3632 } 3633 3634 return true; 3635} 3636 3637 3638/* real, float, sngl. */ 3639bool 3640gfc_check_real (gfc_expr *a, gfc_expr *kind) 3641{ 3642 if (!numeric_check (a, 0)) 3643 return false; 3644 3645 if (!kind_check (kind, 1, BT_REAL)) 3646 return false; 3647 3648 return true; 3649} 3650 3651 3652bool 3653gfc_check_rename (gfc_expr *path1, gfc_expr *path2) 3654{ 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; 3659 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; 3664 3665 return true; 3666} 3667 3668 3669bool 3670gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) 3671{ 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; 3676 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; 3681 3682 if (status == NULL) 3683 return true; 3684 3685 if (!type_check (status, 2, BT_INTEGER)) 3686 return false; 3687 3688 if (!scalar_check (status, 2)) 3689 return false; 3690 3691 return true; 3692} 3693 3694 3695bool 3696gfc_check_repeat (gfc_expr *x, gfc_expr *y) 3697{ 3698 if (!type_check (x, 0, BT_CHARACTER)) 3699 return false; 3700 3701 if (!scalar_check (x, 0)) 3702 return false; 3703 3704 if (!type_check (y, 0, BT_INTEGER)) 3705 return false; 3706 3707 if (!scalar_check (y, 1)) 3708 return false; 3709 3710 return true; 3711} 3712 3713 3714bool 3715gfc_check_reshape (gfc_expr *source, gfc_expr *shape, 3716 gfc_expr *pad, gfc_expr *order) 3717{ 3718 mpz_t size; 3719 mpz_t nelems; 3720 int shape_size; 3721 3722 if (!array_check (source, 0)) 3723 return false; 3724 3725 if (!rank_check (shape, 1, 1)) 3726 return false; 3727 3728 if (!type_check (shape, 1, BT_INTEGER)) 3729 return false; 3730 3731 if (!gfc_array_size (shape, &size)) 3732 { 3733 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an " 3734 "array of constant size", &shape->where); 3735 return false; 3736 } 3737 3738 shape_size = mpz_get_ui (size); 3739 mpz_clear (size); 3740 3741 if (shape_size <= 0) 3742 { 3743 gfc_error ("%qs argument of %qs intrinsic at %L is empty", 3744 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 3745 &shape->where); 3746 return false; 3747 } 3748 else if (shape_size > GFC_MAX_DIMENSIONS) 3749 { 3750 gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more " 3751 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS); 3752 return false; 3753 } 3754 else if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape)) 3755 { 3756 gfc_expr *e; 3757 int i, extent; 3758 for (i = 0; i < shape_size; ++i) 3759 { 3760 e = gfc_constructor_lookup_expr (shape->value.constructor, i); 3761 if (e->expr_type != EXPR_CONSTANT) 3762 continue; 3763 3764 gfc_extract_int (e, &extent); 3765 if (extent < 0) 3766 { 3767 gfc_error ("%qs argument of %qs intrinsic at %L has " 3768 "negative element (%d)", 3769 gfc_current_intrinsic_arg[1]->name, 3770 gfc_current_intrinsic, &e->where, extent); 3771 return false; 3772 } 3773 } 3774 } 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 } 3805 3806 if (pad != NULL) 3807 { 3808 if (!same_type_check (source, 0, pad, 2)) 3809 return false; 3810 3811 if (!array_check (pad, 2)) 3812 return false; 3813 } 3814 3815 if (order != NULL) 3816 { 3817 if (!array_check (order, 3)) 3818 return false; 3819 3820 if (!type_check (order, 3, BT_INTEGER)) 3821 return false; 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 { 3837 gfc_error ("%qs argument of %qs intrinsic at %L " 3838 "has wrong number of elements (%d/%d)", 3839 gfc_current_intrinsic_arg[3]->name, 3840 gfc_current_intrinsic, &order->where, 3841 order_size, shape_size); 3842 return false; 3843 } 3844 3845 for (i = 1; i <= order_size; ++i) 3846 { 3847 e = gfc_constructor_lookup_expr (order->value.constructor, i-1); 3848 if (e->expr_type != EXPR_CONSTANT) 3849 continue; 3850 3851 gfc_extract_int (e, &dim); 3852 3853 if (dim < 1 || dim > order_size) 3854 { 3855 gfc_error ("%qs argument of %qs intrinsic at %L " 3856 "has out-of-range dimension (%d)", 3857 gfc_current_intrinsic_arg[3]->name, 3858 gfc_current_intrinsic, &e->where, dim); 3859 return false; 3860 } 3861 3862 if (perm[dim-1] != 0) 3863 { 3864 gfc_error ("%qs argument of %qs intrinsic at %L has " 3865 "invalid permutation of dimensions (dimension " 3866 "%<%d%> duplicated)", 3867 gfc_current_intrinsic_arg[3]->name, 3868 gfc_current_intrinsic, &e->where, dim); 3869 return false; 3870 } 3871 3872 perm[dim-1] = 1; 3873 } 3874 } 3875 } 3876 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)) 3881 { 3882 /* Check the match in size between source and destination. */ 3883 if (gfc_array_size (source, &nelems)) 3884 { 3885 gfc_constructor *c; 3886 bool test; 3887 3888 3889 mpz_init_set_ui (size, 1); 3890 for (c = gfc_constructor_first (shape->value.constructor); 3891 c; c = gfc_constructor_next (c)) 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 { 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); 3903 return false; 3904 } 3905 } 3906 } 3907 3908 return true; 3909} 3910 3911 3912bool 3913gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) 3914{ 3915 if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) 3916 { 3917 gfc_error ("%qs argument of %qs intrinsic at %L " 3918 "cannot be of type %s", 3919 gfc_current_intrinsic_arg[0]->name, 3920 gfc_current_intrinsic, 3921 &a->where, gfc_typename (&a->ts)); 3922 return false; 3923 } 3924 3925 if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) 3926 { 3927 gfc_error ("%qs argument of %qs intrinsic at %L " 3928 "must be of an extensible type", 3929 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 3930 &a->where); 3931 return false; 3932 } 3933 3934 if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) 3935 { 3936 gfc_error ("%qs argument of %qs intrinsic at %L " 3937 "cannot be of type %s", 3938 gfc_current_intrinsic_arg[0]->name, 3939 gfc_current_intrinsic, 3940 &b->where, gfc_typename (&b->ts)); 3941 return false; 3942 } 3943 3944 if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) 3945 { 3946 gfc_error ("%qs argument of %qs intrinsic at %L " 3947 "must be of an extensible type", 3948 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 3949 &b->where); 3950 return false; 3951 } 3952 3953 return true; 3954} 3955 3956 3957bool 3958gfc_check_scale (gfc_expr *x, gfc_expr *i) 3959{ 3960 if (!type_check (x, 0, BT_REAL)) 3961 return false; 3962 3963 if (!type_check (i, 1, BT_INTEGER)) 3964 return false; 3965 3966 return true; 3967} 3968 3969 3970bool 3971gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) 3972{ 3973 if (!type_check (x, 0, BT_CHARACTER)) 3974 return false; 3975 3976 if (!type_check (y, 1, BT_CHARACTER)) 3977 return false; 3978 3979 if (z != NULL && !type_check (z, 2, BT_LOGICAL)) 3980 return false; 3981 3982 if (!kind_check (kind, 3, BT_INTEGER)) 3983 return false; 3984 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 3985 "with KIND argument at %L", 3986 gfc_current_intrinsic, &kind->where)) 3987 return false; 3988 3989 if (!same_type_check (x, 0, y, 1)) 3990 return false; 3991 3992 return true; 3993} 3994 3995 3996bool 3997gfc_check_secnds (gfc_expr *r) 3998{ 3999 if (!type_check (r, 0, BT_REAL)) 4000 return false; 4001 4002 if (!kind_value_check (r, 0, 4)) 4003 return false; 4004 4005 if (!scalar_check (r, 0)) 4006 return false; 4007 4008 return true; 4009} 4010 4011 4012bool 4013gfc_check_selected_char_kind (gfc_expr *name) 4014{ 4015 if (!type_check (name, 0, BT_CHARACTER)) 4016 return false; 4017 4018 if (!kind_value_check (name, 0, gfc_default_character_kind)) 4019 return false; 4020 4021 if (!scalar_check (name, 0)) 4022 return false; 4023 4024 return true; 4025} 4026 4027 4028bool 4029gfc_check_selected_int_kind (gfc_expr *r) 4030{ 4031 if (!type_check (r, 0, BT_INTEGER)) 4032 return false; 4033 4034 if (!scalar_check (r, 0)) 4035 return false; 4036 4037 return true; 4038} 4039 4040 4041bool 4042gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) 4043{ 4044 if (p == NULL && r == NULL 4045 && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with" 4046 " neither %<P%> nor %<R%> argument at %L", 4047 gfc_current_intrinsic_where)) 4048 return false; 4049 4050 if (p) 4051 { 4052 if (!type_check (p, 0, BT_INTEGER)) 4053 return false; 4054 4055 if (!scalar_check (p, 0)) 4056 return false; 4057 } 4058 4059 if (r) 4060 { 4061 if (!type_check (r, 1, BT_INTEGER)) 4062 return false; 4063 4064 if (!scalar_check (r, 1)) 4065 return false; 4066 } 4067 4068 if (radix) 4069 { 4070 if (!type_check (radix, 1, BT_INTEGER)) 4071 return false; 4072 4073 if (!scalar_check (radix, 1)) 4074 return false; 4075 4076 if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with " 4077 "RADIX argument at %L", gfc_current_intrinsic, 4078 &radix->where)) 4079 return false; 4080 } 4081 4082 return true; 4083} 4084 4085 4086bool 4087gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) 4088{ 4089 if (!type_check (x, 0, BT_REAL)) 4090 return false; 4091 4092 if (!type_check (i, 1, BT_INTEGER)) 4093 return false; 4094 4095 return true; 4096} 4097 4098 4099bool 4100gfc_check_shape (gfc_expr *source, gfc_expr *kind) 4101{ 4102 gfc_array_ref *ar; 4103 4104 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) 4105 return true; 4106 4107 ar = gfc_find_array_ref (source); 4108 4109 if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL) 4110 { 4111 gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be " 4112 "an assumed size array", &source->where); 4113 return false; 4114 } 4115 4116 if (!kind_check (kind, 1, BT_INTEGER)) 4117 return false; 4118 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 4119 "with KIND argument at %L", 4120 gfc_current_intrinsic, &kind->where)) 4121 return false; 4122 4123 return true; 4124} 4125 4126 4127bool 4128gfc_check_shift (gfc_expr *i, gfc_expr *shift) 4129{ 4130 if (!type_check (i, 0, BT_INTEGER)) 4131 return false; 4132 4133 if (!type_check (shift, 0, BT_INTEGER)) 4134 return false; 4135 4136 if (!nonnegative_check ("SHIFT", shift)) 4137 return false; 4138 4139 if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) 4140 return false; 4141 4142 return true; 4143} 4144 4145 4146bool 4147gfc_check_sign (gfc_expr *a, gfc_expr *b) 4148{ 4149 if (!int_or_real_check (a, 0)) 4150 return false; 4151 4152 if (!same_type_check (a, 0, b, 1)) 4153 return false; 4154 4155 return true; 4156} 4157 4158 4159bool 4160gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 4161{ 4162 if (!array_check (array, 0)) 4163 return false; 4164 4165 if (!dim_check (dim, 1, true)) 4166 return false; 4167 4168 if (!dim_rank_check (dim, array, 0)) 4169 return false; 4170 4171 if (!kind_check (kind, 2, BT_INTEGER)) 4172 return false; 4173 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 4174 "with KIND argument at %L", 4175 gfc_current_intrinsic, &kind->where)) 4176 return false; 4177 4178 4179 return true; 4180} 4181 4182 4183bool 4184gfc_check_sizeof (gfc_expr *arg) 4185{ 4186 if (arg->ts.type == BT_PROCEDURE) 4187 { 4188 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", 4189 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 4190 &arg->where); 4191 return false; 4192 } 4193 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))) 4200 { 4201 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", 4202 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 4203 &arg->where); 4204 return false; 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 { 4212 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " 4213 "assumed-size array", gfc_current_intrinsic_arg[0]->name, 4214 gfc_current_intrinsic, &arg->where); 4215 return false; 4216 } 4217 4218 return true; 4219} 4220 4221 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. 4225 If c_loc is true, character with len > 1 are allowed (cf. Fortran 4226 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape 4227 arrays are permitted. And if c_f_ptr is true, deferred-shape arrays 4228 are permitted. */ 4229 4230static bool 4231is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr) 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, 4275 but it is not an interoperable type. */ 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 4281 && !gfc_simplify_expr (expr, 0)) 4282 gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed"); 4283 4284 if (!c_loc && expr->ts.u.cl 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 4304 if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY) 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 } 4312 if (!c_f_ptr && ar->as->type != AS_EXPLICIT 4313 && ar->as->type != AS_ASSUMED_SIZE) 4314 { 4315 *msg = "Only explicit-size and assumed-size arrays are interoperable"; 4316 return false; 4317 } 4318 } 4319 4320 return true; 4321} 4322 4323 4324bool 4325gfc_check_c_sizeof (gfc_expr *arg) 4326{ 4327 const char *msg; 4328 4329 if (!is_c_interoperable (arg, &msg, false, false)) 4330 { 4331 gfc_error ("%qs argument of %qs intrinsic at %L must be an " 4332 "interoperable data entity: %s", 4333 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 4334 &arg->where, msg); 4335 return false; 4336 } 4337 4338 if (arg->ts.type == BT_ASSUMED) 4339 { 4340 gfc_error ("%qs argument of %qs intrinsic at %L shall not be " 4341 "TYPE(*)", 4342 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 4343 &arg->where); 4344 return false; 4345 } 4346 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 { 4352 gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " 4353 "assumed-size array", gfc_current_intrinsic_arg[0]->name, 4354 gfc_current_intrinsic, &arg->where); 4355 return false; 4356 } 4357 4358 return true; 4359} 4360 4361 4362bool 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); 4372 return false; 4373 } 4374 4375 if (!scalar_check (c_ptr_1, 0)) 4376 return false; 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)); 4388 return false; 4389 } 4390 4391 if (c_ptr_2 && !scalar_check (c_ptr_2, 1)) 4392 return false; 4393 4394 return true; 4395} 4396 4397 4398bool 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); 4410 return false; 4411 } 4412 4413 if (!scalar_check (cptr, 0)) 4414 return false; 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); 4422 return false; 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); 4429 return false; 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); 4436 return false; 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); 4443 return false; 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); 4449 return false; 4450 } 4451 4452 if (shape && !rank_check (shape, 2, 1)) 4453 return false; 4454 4455 if (shape && !type_check (shape, 2, BT_INTEGER)) 4456 return false; 4457 4458 if (shape) 4459 { 4460 mpz_t size; 4461 if (gfc_array_size (shape, &size)) 4462 { 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 } 4470 mpz_clear (size); 4471 } 4472 } 4473 4474 if (fptr->ts.type == BT_CLASS) 4475 { 4476 gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where); 4477 return false; 4478 } 4479 4480 if (!is_c_interoperable (fptr, &msg, false, true)) 4481 return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR " 4482 "at %L to C_F_POINTER: %s", &fptr->where, msg); 4483 4484 return true; 4485} 4486 4487 4488bool 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); 4499 return false; 4500 } 4501 4502 if (!scalar_check (cptr, 0)) 4503 return false; 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); 4511 return false; 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); 4518 return false; 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 4525 return true; 4526} 4527 4528 4529bool 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); 4538 return false; 4539 } 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 { 4551 gfc_error ("Function result %qs at %L is invalid as X argument " 4552 "to C_FUNLOC", x->symtree->n.sym->name, &x->where); 4553 return false; 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); 4561 return false; 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); 4567 return true; 4568} 4569 4570 4571bool 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); 4580 return false; 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); 4587 return false; 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); 4598 return false; 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); 4606 return false; 4607 } 4608 4609 if (!is_c_interoperable (x, &msg, true, false)) 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); 4615 return false; 4616 } 4617 4618 if (x->rank 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; 4623 } 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 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; 4635 else if (ar->type != AR_FULL 4636 && !gfc_notify_std (GFC_STD_F2008, "Array section at %L " 4637 "to C_LOC", &x->where)) 4638 return false; 4639 } 4640 4641 return true; 4642} 4643 4644 4645bool 4646gfc_check_sleep_sub (gfc_expr *seconds) 4647{ 4648 if (!type_check (seconds, 0, BT_INTEGER)) 4649 return false; 4650 4651 if (!scalar_check (seconds, 0)) 4652 return false; 4653 4654 return true; 4655} 4656 4657bool 4658gfc_check_sngl (gfc_expr *a) 4659{ 4660 if (!type_check (a, 0, BT_REAL)) 4661 return false; 4662 4663 if ((a->ts.kind != gfc_default_double_kind) 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; 4668 4669 return true; 4670} 4671 4672bool 4673gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) 4674{ 4675 if (source->rank >= GFC_MAX_DIMENSIONS) 4676 { 4677 gfc_error ("%qs argument of %qs intrinsic at %L must be less " 4678 "than rank %d", gfc_current_intrinsic_arg[0]->name, 4679 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); 4680 4681 return false; 4682 } 4683 4684 if (dim == NULL) 4685 return false; 4686 4687 if (!dim_check (dim, 1, false)) 4688 return false; 4689 4690 /* dim_rank_check() does not apply here. */ 4691 if (dim 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 { 4696 gfc_error ("%qs argument of %qs intrinsic at %L is not a valid " 4697 "dimension index", gfc_current_intrinsic_arg[1]->name, 4698 gfc_current_intrinsic, &dim->where); 4699 return false; 4700 } 4701 4702 if (!type_check (ncopies, 2, BT_INTEGER)) 4703 return false; 4704 4705 if (!scalar_check (ncopies, 2)) 4706 return false; 4707 4708 return true; 4709} 4710 4711 4712/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and 4713 functions). */ 4714 4715bool 4716gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) 4717{ 4718 if (!type_check (unit, 0, BT_INTEGER)) 4719 return false; 4720 4721 if (!scalar_check (unit, 0)) 4722 return false; 4723 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; 4728 4729 if (status == NULL) 4730 return true; 4731 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; 4736 4737 return true; 4738} 4739 4740 4741bool 4742gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c) 4743{ 4744 return gfc_check_fgetputc_sub (unit, c, NULL); 4745} 4746 4747 4748bool 4749gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) 4750{ 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; 4755 4756 if (status == NULL) 4757 return true; 4758 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; 4763 4764 return true; 4765} 4766 4767 4768bool 4769gfc_check_fgetput (gfc_expr *c) 4770{ 4771 return gfc_check_fgetput_sub (c, NULL); 4772} 4773 4774 4775bool 4776gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status) 4777{ 4778 if (!type_check (unit, 0, BT_INTEGER)) 4779 return false; 4780 4781 if (!scalar_check (unit, 0)) 4782 return false; 4783 4784 if (!type_check (offset, 1, BT_INTEGER)) 4785 return false; 4786 4787 if (!scalar_check (offset, 1)) 4788 return false; 4789 4790 if (!type_check (whence, 2, BT_INTEGER)) 4791 return false; 4792 4793 if (!scalar_check (whence, 2)) 4794 return false; 4795 4796 if (status == NULL) 4797 return true; 4798 4799 if (!type_check (status, 3, BT_INTEGER)) 4800 return false; 4801 4802 if (!kind_value_check (status, 3, 4)) 4803 return false; 4804 4805 if (!scalar_check (status, 3)) 4806 return false; 4807 4808 return true; 4809} 4810 4811 4812 4813bool 4814gfc_check_fstat (gfc_expr *unit, gfc_expr *array) 4815{ 4816 if (!type_check (unit, 0, BT_INTEGER)) 4817 return false; 4818 4819 if (!scalar_check (unit, 0)) 4820 return false; 4821 4822 if (!type_check (array, 1, BT_INTEGER) 4823 || !kind_value_check (unit, 0, gfc_default_integer_kind)) 4824 return false; 4825 4826 if (!array_check (array, 1)) 4827 return false; 4828 4829 return true; 4830} 4831 4832 4833bool 4834gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) 4835{ 4836 if (!type_check (unit, 0, BT_INTEGER)) 4837 return false; 4838 4839 if (!scalar_check (unit, 0)) 4840 return false; 4841 4842 if (!type_check (array, 1, BT_INTEGER) 4843 || !kind_value_check (array, 1, gfc_default_integer_kind)) 4844 return false; 4845 4846 if (!array_check (array, 1)) 4847 return false; 4848 4849 if (status == NULL) 4850 return true; 4851 4852 if (!type_check (status, 2, BT_INTEGER) 4853 || !kind_value_check (status, 2, gfc_default_integer_kind)) 4854 return false; 4855 4856 if (!scalar_check (status, 2)) 4857 return false; 4858 4859 return true; 4860} 4861 4862 4863bool 4864gfc_check_ftell (gfc_expr *unit) 4865{ 4866 if (!type_check (unit, 0, BT_INTEGER)) 4867 return false; 4868 4869 if (!scalar_check (unit, 0)) 4870 return false; 4871 4872 return true; 4873} 4874 4875 4876bool 4877gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) 4878{ 4879 if (!type_check (unit, 0, BT_INTEGER)) 4880 return false; 4881 4882 if (!scalar_check (unit, 0)) 4883 return false; 4884 4885 if (!type_check (offset, 1, BT_INTEGER)) 4886 return false; 4887 4888 if (!scalar_check (offset, 1)) 4889 return false; 4890 4891 return true; 4892} 4893 4894 4895bool 4896gfc_check_stat (gfc_expr *name, gfc_expr *array) 4897{ 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; 4902 4903 if (!type_check (array, 1, BT_INTEGER) 4904 || !kind_value_check (array, 1, gfc_default_integer_kind)) 4905 return false; 4906 4907 if (!array_check (array, 1)) 4908 return false; 4909 4910 return true; 4911} 4912 4913 4914bool 4915gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) 4916{ 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; 4921 4922 if (!type_check (array, 1, BT_INTEGER) 4923 || !kind_value_check (array, 1, gfc_default_integer_kind)) 4924 return false; 4925 4926 if (!array_check (array, 1)) 4927 return false; 4928 4929 if (status == NULL) 4930 return true; 4931 4932 if (!type_check (status, 2, BT_INTEGER) 4933 || !kind_value_check (array, 1, gfc_default_integer_kind)) 4934 return false; 4935 4936 if (!scalar_check (status, 2)) 4937 return false; 4938 4939 return true; 4940} 4941 4942 4943bool 4944gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) 4945{ 4946 mpz_t nelems; 4947 4948 if (flag_coarray == GFC_FCOARRAY_NONE) 4949 { 4950 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 4951 return false; 4952 } 4953 4954 if (!coarray_check (coarray, 0)) 4955 return false; 4956 4957 if (sub->rank != 1) 4958 { 4959 gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", 4960 gfc_current_intrinsic_arg[1]->name, &sub->where); 4961 return false; 4962 } 4963 4964 if (gfc_array_size (sub, &nelems)) 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); 4974 return false; 4975 } 4976 mpz_clear (nelems); 4977 } 4978 4979 return true; 4980} 4981 4982 4983bool 4984gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) 4985{ 4986 if (flag_coarray == GFC_FCOARRAY_NONE) 4987 { 4988 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 4989 return false; 4990 } 4991 4992 if (distance) 4993 { 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{ 5028 if (flag_coarray == GFC_FCOARRAY_NONE) 5029 { 5030 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 5031 return false; 5032 } 5033 5034 if (coarray == NULL && dim == NULL && distance == NULL) 5035 return true; 5036 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 5082 if (!coarray_check (coarray, 0)) 5083 return false; 5084 5085 if (dim != NULL) 5086 { 5087 if (!dim_check (dim, 1, false)) 5088 return false; 5089 5090 if (!dim_corank_check (dim, coarray)) 5091 return false; 5092 } 5093 5094 return true; 5095} 5096 5097/* Calculate the sizes for transfer, used by gfc_check_transfer and also 5098 by gfc_simplify_transfer. Return false if we cannot do so. */ 5099 5100bool 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) 5104{ 5105 size_t result_elt_size; 5106 5107 if (source->expr_type == EXPR_FUNCTION) 5108 return false; 5109 5110 if (size && size->expr_type != EXPR_CONSTANT) 5111 return false; 5112 5113 /* Calculate the size of the source. */ 5114 *source_size = gfc_target_expr_size (source); 5115 if (*source_size == 0) 5116 return false; 5117 5118 /* Determine the size of the element. */ 5119 result_elt_size = gfc_element_size (mold); 5120 if (result_elt_size == 0) 5121 return false; 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 5143 return true; 5144} 5145 5146 5147bool 5148gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 5149{ 5150 size_t source_size; 5151 size_t result_size; 5152 5153 if (mold->ts.type == BT_HOLLERITH) 5154 { 5155 gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be" 5156 " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH)); 5157 return false; 5158 } 5159 5160 if (size != NULL) 5161 { 5162 if (!type_check (size, 2, BT_INTEGER)) 5163 return false; 5164 5165 if (!scalar_check (size, 2)) 5166 return false; 5167 5168 if (!nonoptional_check (size, 2)) 5169 return false; 5170 } 5171 5172 if (!warn_surprising) 5173 return true; 5174 5175 /* If we can't calculate the sizes, we cannot check any more. 5176 Return true for that case. */ 5177 5178 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, 5179 &result_size, NULL)) 5180 return true; 5181 5182 if (source_size < result_size) 5183 gfc_warning (0, "Intrinsic TRANSFER at %L has partly undefined result: " 5184 "source size %ld < result size %ld", &source->where, 5185 (long) source_size, (long) result_size); 5186 5187 return true; 5188} 5189 5190 5191bool 5192gfc_check_transpose (gfc_expr *matrix) 5193{ 5194 if (!rank_check (matrix, 0, 2)) 5195 return false; 5196 5197 return true; 5198} 5199 5200 5201bool 5202gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 5203{ 5204 if (!array_check (array, 0)) 5205 return false; 5206 5207 if (!dim_check (dim, 1, false)) 5208 return false; 5209 5210 if (!dim_rank_check (dim, array, 0)) 5211 return false; 5212 5213 if (!kind_check (kind, 2, BT_INTEGER)) 5214 return false; 5215 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 5216 "with KIND argument at %L", 5217 gfc_current_intrinsic, &kind->where)) 5218 return false; 5219 5220 return true; 5221} 5222 5223 5224bool 5225gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) 5226{ 5227 if (flag_coarray == GFC_FCOARRAY_NONE) 5228 { 5229 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 5230 return false; 5231 } 5232 5233 if (!coarray_check (coarray, 0)) 5234 return false; 5235 5236 if (dim != NULL) 5237 { 5238 if (!dim_check (dim, 1, false)) 5239 return false; 5240 5241 if (!dim_corank_check (dim, coarray)) 5242 return false; 5243 } 5244 5245 if (!kind_check (kind, 2, BT_INTEGER)) 5246 return false; 5247 5248 return true; 5249} 5250 5251 5252bool 5253gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) 5254{ 5255 mpz_t vector_size; 5256 5257 if (!rank_check (vector, 0, 1)) 5258 return false; 5259 5260 if (!array_check (mask, 1)) 5261 return false; 5262 5263 if (!type_check (mask, 1, BT_LOGICAL)) 5264 return false; 5265 5266 if (!same_type_check (vector, 0, field, 2)) 5267 return false; 5268 5269 if (mask->expr_type == EXPR_ARRAY 5270 && gfc_array_size (vector, &vector_size)) 5271 { 5272 int mask_true_count = 0; 5273 gfc_constructor *mask_ctor; 5274 mask_ctor = gfc_constructor_first (mask->value.constructor); 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 5286 mask_ctor = gfc_constructor_next (mask_ctor); 5287 } 5288 5289 if (mpz_get_si (vector_size) < mask_true_count) 5290 { 5291 gfc_error ("%qs argument of %qs intrinsic at %L must " 5292 "provide at least as many elements as there " 5293 "are .TRUE. values in %qs (%ld/%d)", 5294 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 5295 &vector->where, gfc_current_intrinsic_arg[1]->name, 5296 mpz_get_si (vector_size), mask_true_count); 5297 return false; 5298 } 5299 5300 mpz_clear (vector_size); 5301 } 5302 5303 if (mask->rank != field->rank && field->rank != 0) 5304 { 5305 gfc_error ("%qs argument of %qs intrinsic at %L must have " 5306 "the same rank as %qs or be a scalar", 5307 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, 5308 &field->where, gfc_current_intrinsic_arg[1]->name); 5309 return false; 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 { 5318 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L " 5319 "must have identical shape.", 5320 gfc_current_intrinsic_arg[2]->name, 5321 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 5322 &field->where); 5323 } 5324 } 5325 5326 return true; 5327} 5328 5329 5330bool 5331gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) 5332{ 5333 if (!type_check (x, 0, BT_CHARACTER)) 5334 return false; 5335 5336 if (!same_type_check (x, 0, y, 1)) 5337 return false; 5338 5339 if (z != NULL && !type_check (z, 2, BT_LOGICAL)) 5340 return false; 5341 5342 if (!kind_check (kind, 3, BT_INTEGER)) 5343 return false; 5344 if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " 5345 "with KIND argument at %L", 5346 gfc_current_intrinsic, &kind->where)) 5347 return false; 5348 5349 return true; 5350} 5351 5352 5353bool 5354gfc_check_trim (gfc_expr *x) 5355{ 5356 if (!type_check (x, 0, BT_CHARACTER)) 5357 return false; 5358 5359 if (!scalar_check (x, 0)) 5360 return false; 5361 5362 return true; 5363} 5364 5365 5366bool 5367gfc_check_ttynam (gfc_expr *unit) 5368{ 5369 if (!scalar_check (unit, 0)) 5370 return false; 5371 5372 if (!type_check (unit, 0, BT_INTEGER)) 5373 return false; 5374 5375 return true; 5376} 5377 5378 5379/* Common check function for the half a dozen intrinsics that have a 5380 single real argument. */ 5381 5382bool 5383gfc_check_x (gfc_expr *x) 5384{ 5385 if (!type_check (x, 0, BT_REAL)) 5386 return false; 5387 5388 return true; 5389} 5390 5391 5392/************* Check functions for intrinsic subroutines *************/ 5393 5394bool 5395gfc_check_cpu_time (gfc_expr *time) 5396{ 5397 if (!scalar_check (time, 0)) 5398 return false; 5399 5400 if (!type_check (time, 0, BT_REAL)) 5401 return false; 5402 5403 if (!variable_check (time, 0, false)) 5404 return false; 5405 5406 return true; 5407} 5408 5409 5410bool 5411gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, 5412 gfc_expr *zone, gfc_expr *values) 5413{ 5414 if (date != NULL) 5415 { 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; 5424 } 5425 5426 if (time != NULL) 5427 { 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; 5436 } 5437 5438 if (zone != NULL) 5439 { 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; 5448 } 5449 5450 if (values != NULL) 5451 { 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; 5460 } 5461 5462 return true; 5463} 5464 5465 5466bool 5467gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, 5468 gfc_expr *to, gfc_expr *topos) 5469{ 5470 if (!type_check (from, 0, BT_INTEGER)) 5471 return false; 5472 5473 if (!type_check (frompos, 1, BT_INTEGER)) 5474 return false; 5475 5476 if (!type_check (len, 2, BT_INTEGER)) 5477 return false; 5478 5479 if (!same_type_check (from, 0, to, 3)) 5480 return false; 5481 5482 if (!variable_check (to, 3, false)) 5483 return false; 5484 5485 if (!type_check (topos, 4, BT_INTEGER)) 5486 return false; 5487 5488 if (!nonnegative_check ("frompos", frompos)) 5489 return false; 5490 5491 if (!nonnegative_check ("topos", topos)) 5492 return false; 5493 5494 if (!nonnegative_check ("len", len)) 5495 return false; 5496 5497 if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)) 5498 return false; 5499 5500 if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len)) 5501 return false; 5502 5503 return true; 5504} 5505 5506 5507bool 5508gfc_check_random_number (gfc_expr *harvest) 5509{ 5510 if (!type_check (harvest, 0, BT_REAL)) 5511 return false; 5512 5513 if (!variable_check (harvest, 0, false)) 5514 return false; 5515 5516 return true; 5517} 5518 5519 5520bool 5521gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) 5522{ 5523 unsigned int nargs = 0, kiss_size; 5524 locus *where = NULL; 5525 mpz_t put_size, get_size; 5526 bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */ 5527 5528 have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1; 5529 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 5534 if (size != NULL) 5535 { 5536 if (size->expr_type != EXPR_VARIABLE 5537 || !size->symtree->n.sym->attr.optional) 5538 nargs++; 5539 5540 if (!scalar_check (size, 0)) 5541 return false; 5542 5543 if (!type_check (size, 0, BT_INTEGER)) 5544 return false; 5545 5546 if (!variable_check (size, 0, false)) 5547 return false; 5548 5549 if (!kind_value_check (size, 0, gfc_default_integer_kind)) 5550 return false; 5551 } 5552 5553 if (put != NULL) 5554 { 5555 if (put->expr_type != EXPR_VARIABLE 5556 || !put->symtree->n.sym->attr.optional) 5557 { 5558 nargs++; 5559 where = &put->where; 5560 } 5561 5562 if (!array_check (put, 1)) 5563 return false; 5564 5565 if (!rank_check (put, 1, 1)) 5566 return false; 5567 5568 if (!type_check (put, 1, BT_INTEGER)) 5569 return false; 5570 5571 if (!kind_value_check (put, 1, gfc_default_integer_kind)) 5572 return false; 5573 5574 if (gfc_array_size (put, &put_size) 5575 && mpz_get_ui (put_size) < kiss_size) 5576 gfc_error ("Size of %qs argument of %qs intrinsic at %L " 5577 "too small (%i/%i)", 5578 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 5579 where, (int) mpz_get_ui (put_size), kiss_size); 5580 } 5581 5582 if (get != NULL) 5583 { 5584 if (get->expr_type != EXPR_VARIABLE 5585 || !get->symtree->n.sym->attr.optional) 5586 { 5587 nargs++; 5588 where = &get->where; 5589 } 5590 5591 if (!array_check (get, 2)) 5592 return false; 5593 5594 if (!rank_check (get, 2, 1)) 5595 return false; 5596 5597 if (!type_check (get, 2, BT_INTEGER)) 5598 return false; 5599 5600 if (!variable_check (get, 2, false)) 5601 return false; 5602 5603 if (!kind_value_check (get, 2, gfc_default_integer_kind)) 5604 return false; 5605 5606 if (gfc_array_size (get, &get_size) 5607 && mpz_get_ui (get_size) < kiss_size) 5608 gfc_error ("Size of %qs argument of %qs intrinsic at %L " 5609 "too small (%i/%i)", 5610 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, 5611 where, (int) mpz_get_ui (get_size), kiss_size); 5612 } 5613 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 5618 return true; 5619} 5620 5621 5622bool 5623gfc_check_second_sub (gfc_expr *time) 5624{ 5625 if (!scalar_check (time, 0)) 5626 return false; 5627 5628 if (!type_check (time, 0, BT_REAL)) 5629 return false; 5630 5631 if (!kind_value_check (time, 0, 4)) 5632 return false; 5633 5634 return true; 5635} 5636 5637 5638/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer 5639 variables in Fortran 95. In Fortran 2003 and later, they can be of any 5640 kind, and COUNT_RATE can be of type real. Note, count, count_rate, and 5641 count_max are all optional arguments */ 5642 5643bool 5644gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, 5645 gfc_expr *count_max) 5646{ 5647 if (count != NULL) 5648 { 5649 if (!scalar_check (count, 0)) 5650 return false; 5651 5652 if (!type_check (count, 0, BT_INTEGER)) 5653 return false; 5654 5655 if (count->ts.kind != gfc_default_integer_kind 5656 && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to " 5657 "SYSTEM_CLOCK at %L has non-default kind", 5658 &count->where)) 5659 return false; 5660 5661 if (!variable_check (count, 0, false)) 5662 return false; 5663 } 5664 5665 if (count_rate != NULL) 5666 { 5667 if (!scalar_check (count_rate, 1)) 5668 return false; 5669 5670 if (!variable_check (count_rate, 1, false)) 5671 return false; 5672 5673 if (count_rate->ts.type == BT_REAL) 5674 { 5675 if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to " 5676 "SYSTEM_CLOCK at %L", &count_rate->where)) 5677 return false; 5678 } 5679 else 5680 { 5681 if (!type_check (count_rate, 1, BT_INTEGER)) 5682 return false; 5683 5684 if (count_rate->ts.kind != gfc_default_integer_kind 5685 && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to " 5686 "SYSTEM_CLOCK at %L has non-default kind", 5687 &count_rate->where)) 5688 return false; 5689 } 5690 5691 } 5692 5693 if (count_max != NULL) 5694 { 5695 if (!scalar_check (count_max, 2)) 5696 return false; 5697 5698 if (!type_check (count_max, 2, BT_INTEGER)) 5699 return false; 5700 5701 if (count_max->ts.kind != gfc_default_integer_kind 5702 && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to " 5703 "SYSTEM_CLOCK at %L has non-default kind", 5704 &count_max->where)) 5705 return false; 5706 5707 if (!variable_check (count_max, 2, false)) 5708 return false; 5709 } 5710 5711 return true; 5712} 5713 5714 5715bool 5716gfc_check_irand (gfc_expr *x) 5717{ 5718 if (x == NULL) 5719 return true; 5720 5721 if (!scalar_check (x, 0)) 5722 return false; 5723 5724 if (!type_check (x, 0, BT_INTEGER)) 5725 return false; 5726 5727 if (!kind_value_check (x, 0, 4)) 5728 return false; 5729 5730 return true; 5731} 5732 5733 5734bool 5735gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) 5736{ 5737 if (!scalar_check (seconds, 0)) 5738 return false; 5739 if (!type_check (seconds, 0, BT_INTEGER)) 5740 return false; 5741 5742 if (!int_or_proc_check (handler, 1)) 5743 return false; 5744 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) 5745 return false; 5746 5747 if (status == NULL) 5748 return true; 5749 5750 if (!scalar_check (status, 2)) 5751 return false; 5752 if (!type_check (status, 2, BT_INTEGER)) 5753 return false; 5754 if (!kind_value_check (status, 2, gfc_default_integer_kind)) 5755 return false; 5756 5757 return true; 5758} 5759 5760 5761bool 5762gfc_check_rand (gfc_expr *x) 5763{ 5764 if (x == NULL) 5765 return true; 5766 5767 if (!scalar_check (x, 0)) 5768 return false; 5769 5770 if (!type_check (x, 0, BT_INTEGER)) 5771 return false; 5772 5773 if (!kind_value_check (x, 0, 4)) 5774 return false; 5775 5776 return true; 5777} 5778 5779 5780bool 5781gfc_check_srand (gfc_expr *x) 5782{ 5783 if (!scalar_check (x, 0)) 5784 return false; 5785 5786 if (!type_check (x, 0, BT_INTEGER)) 5787 return false; 5788 5789 if (!kind_value_check (x, 0, 4)) 5790 return false; 5791 5792 return true; 5793} 5794 5795 5796bool 5797gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) 5798{ 5799 if (!scalar_check (time, 0)) 5800 return false; 5801 if (!type_check (time, 0, BT_INTEGER)) 5802 return false; 5803 5804 if (!type_check (result, 1, BT_CHARACTER)) 5805 return false; 5806 if (!kind_value_check (result, 1, gfc_default_character_kind)) 5807 return false; 5808 5809 return true; 5810} 5811 5812 5813bool 5814gfc_check_dtime_etime (gfc_expr *x) 5815{ 5816 if (!array_check (x, 0)) 5817 return false; 5818 5819 if (!rank_check (x, 0, 1)) 5820 return false; 5821 5822 if (!variable_check (x, 0, false)) 5823 return false; 5824 5825 if (!type_check (x, 0, BT_REAL)) 5826 return false; 5827 5828 if (!kind_value_check (x, 0, 4)) 5829 return false; 5830 5831 return true; 5832} 5833 5834 5835bool 5836gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) 5837{ 5838 if (!array_check (values, 0)) 5839 return false; 5840 5841 if (!rank_check (values, 0, 1)) 5842 return false; 5843 5844 if (!variable_check (values, 0, false)) 5845 return false; 5846 5847 if (!type_check (values, 0, BT_REAL)) 5848 return false; 5849 5850 if (!kind_value_check (values, 0, 4)) 5851 return false; 5852 5853 if (!scalar_check (time, 1)) 5854 return false; 5855 5856 if (!type_check (time, 1, BT_REAL)) 5857 return false; 5858 5859 if (!kind_value_check (time, 1, 4)) 5860 return false; 5861 5862 return true; 5863} 5864 5865 5866bool 5867gfc_check_fdate_sub (gfc_expr *date) 5868{ 5869 if (!type_check (date, 0, BT_CHARACTER)) 5870 return false; 5871 if (!kind_value_check (date, 0, gfc_default_character_kind)) 5872 return false; 5873 5874 return true; 5875} 5876 5877 5878bool 5879gfc_check_gerror (gfc_expr *msg) 5880{ 5881 if (!type_check (msg, 0, BT_CHARACTER)) 5882 return false; 5883 if (!kind_value_check (msg, 0, gfc_default_character_kind)) 5884 return false; 5885 5886 return true; 5887} 5888 5889 5890bool 5891gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) 5892{ 5893 if (!type_check (cwd, 0, BT_CHARACTER)) 5894 return false; 5895 if (!kind_value_check (cwd, 0, gfc_default_character_kind)) 5896 return false; 5897 5898 if (status == NULL) 5899 return true; 5900 5901 if (!scalar_check (status, 1)) 5902 return false; 5903 5904 if (!type_check (status, 1, BT_INTEGER)) 5905 return false; 5906 5907 return true; 5908} 5909 5910 5911bool 5912gfc_check_getarg (gfc_expr *pos, gfc_expr *value) 5913{ 5914 if (!type_check (pos, 0, BT_INTEGER)) 5915 return false; 5916 5917 if (pos->ts.kind > gfc_default_integer_kind) 5918 { 5919 gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind " 5920 "not wider than the default kind (%d)", 5921 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 5922 &pos->where, gfc_default_integer_kind); 5923 return false; 5924 } 5925 5926 if (!type_check (value, 1, BT_CHARACTER)) 5927 return false; 5928 if (!kind_value_check (value, 1, gfc_default_character_kind)) 5929 return false; 5930 5931 return true; 5932} 5933 5934 5935bool 5936gfc_check_getlog (gfc_expr *msg) 5937{ 5938 if (!type_check (msg, 0, BT_CHARACTER)) 5939 return false; 5940 if (!kind_value_check (msg, 0, gfc_default_character_kind)) 5941 return false; 5942 5943 return true; 5944} 5945 5946 5947bool 5948gfc_check_exit (gfc_expr *status) 5949{ 5950 if (status == NULL) 5951 return true; 5952 5953 if (!type_check (status, 0, BT_INTEGER)) 5954 return false; 5955 5956 if (!scalar_check (status, 0)) 5957 return false; 5958 5959 return true; 5960} 5961 5962 5963bool 5964gfc_check_flush (gfc_expr *unit) 5965{ 5966 if (unit == NULL) 5967 return true; 5968 5969 if (!type_check (unit, 0, BT_INTEGER)) 5970 return false; 5971 5972 if (!scalar_check (unit, 0)) 5973 return false; 5974 5975 return true; 5976} 5977 5978 5979bool 5980gfc_check_free (gfc_expr *i) 5981{ 5982 if (!type_check (i, 0, BT_INTEGER)) 5983 return false; 5984 5985 if (!scalar_check (i, 0)) 5986 return false; 5987 5988 return true; 5989} 5990 5991 5992bool 5993gfc_check_hostnm (gfc_expr *name) 5994{ 5995 if (!type_check (name, 0, BT_CHARACTER)) 5996 return false; 5997 if (!kind_value_check (name, 0, gfc_default_character_kind)) 5998 return false; 5999 6000 return true; 6001} 6002 6003 6004bool 6005gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) 6006{ 6007 if (!type_check (name, 0, BT_CHARACTER)) 6008 return false; 6009 if (!kind_value_check (name, 0, gfc_default_character_kind)) 6010 return false; 6011 6012 if (status == NULL) 6013 return true; 6014 6015 if (!scalar_check (status, 1)) 6016 return false; 6017 6018 if (!type_check (status, 1, BT_INTEGER)) 6019 return false; 6020 6021 return true; 6022} 6023 6024 6025bool 6026gfc_check_itime_idate (gfc_expr *values) 6027{ 6028 if (!array_check (values, 0)) 6029 return false; 6030 6031 if (!rank_check (values, 0, 1)) 6032 return false; 6033 6034 if (!variable_check (values, 0, false)) 6035 return false; 6036 6037 if (!type_check (values, 0, BT_INTEGER)) 6038 return false; 6039 6040 if (!kind_value_check (values, 0, gfc_default_integer_kind)) 6041 return false; 6042 6043 return true; 6044} 6045 6046 6047bool 6048gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) 6049{ 6050 if (!type_check (time, 0, BT_INTEGER)) 6051 return false; 6052 6053 if (!kind_value_check (time, 0, gfc_default_integer_kind)) 6054 return false; 6055 6056 if (!scalar_check (time, 0)) 6057 return false; 6058 6059 if (!array_check (values, 1)) 6060 return false; 6061 6062 if (!rank_check (values, 1, 1)) 6063 return false; 6064 6065 if (!variable_check (values, 1, false)) 6066 return false; 6067 6068 if (!type_check (values, 1, BT_INTEGER)) 6069 return false; 6070 6071 if (!kind_value_check (values, 1, gfc_default_integer_kind)) 6072 return false; 6073 6074 return true; 6075} 6076 6077 6078bool 6079gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) 6080{ 6081 if (!scalar_check (unit, 0)) 6082 return false; 6083 6084 if (!type_check (unit, 0, BT_INTEGER)) 6085 return false; 6086 6087 if (!type_check (name, 1, BT_CHARACTER)) 6088 return false; 6089 if (!kind_value_check (name, 1, gfc_default_character_kind)) 6090 return false; 6091 6092 return true; 6093} 6094 6095 6096bool 6097gfc_check_isatty (gfc_expr *unit) 6098{ 6099 if (unit == NULL) 6100 return false; 6101 6102 if (!type_check (unit, 0, BT_INTEGER)) 6103 return false; 6104 6105 if (!scalar_check (unit, 0)) 6106 return false; 6107 6108 return true; 6109} 6110 6111 6112bool 6113gfc_check_isnan (gfc_expr *x) 6114{ 6115 if (!type_check (x, 0, BT_REAL)) 6116 return false; 6117 6118 return true; 6119} 6120 6121 6122bool 6123gfc_check_perror (gfc_expr *string) 6124{ 6125 if (!type_check (string, 0, BT_CHARACTER)) 6126 return false; 6127 if (!kind_value_check (string, 0, gfc_default_character_kind)) 6128 return false; 6129 6130 return true; 6131} 6132 6133 6134bool 6135gfc_check_umask (gfc_expr *mask) 6136{ 6137 if (!type_check (mask, 0, BT_INTEGER)) 6138 return false; 6139 6140 if (!scalar_check (mask, 0)) 6141 return false; 6142 6143 return true; 6144} 6145 6146 6147bool 6148gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old) 6149{ 6150 if (!type_check (mask, 0, BT_INTEGER)) 6151 return false; 6152 6153 if (!scalar_check (mask, 0)) 6154 return false; 6155 6156 if (old == NULL) 6157 return true; 6158 6159 if (!scalar_check (old, 1)) 6160 return false; 6161 6162 if (!type_check (old, 1, BT_INTEGER)) 6163 return false; 6164 6165 return true; 6166} 6167 6168 6169bool 6170gfc_check_unlink (gfc_expr *name) 6171{ 6172 if (!type_check (name, 0, BT_CHARACTER)) 6173 return false; 6174 if (!kind_value_check (name, 0, gfc_default_character_kind)) 6175 return false; 6176 6177 return true; 6178} 6179 6180 6181bool 6182gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) 6183{ 6184 if (!type_check (name, 0, BT_CHARACTER)) 6185 return false; 6186 if (!kind_value_check (name, 0, gfc_default_character_kind)) 6187 return false; 6188 6189 if (status == NULL) 6190 return true; 6191 6192 if (!scalar_check (status, 1)) 6193 return false; 6194 6195 if (!type_check (status, 1, BT_INTEGER)) 6196 return false; 6197 6198 return true; 6199} 6200 6201 6202bool 6203gfc_check_signal (gfc_expr *number, gfc_expr *handler) 6204{ 6205 if (!scalar_check (number, 0)) 6206 return false; 6207 if (!type_check (number, 0, BT_INTEGER)) 6208 return false; 6209 6210 if (!int_or_proc_check (handler, 1)) 6211 return false; 6212 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) 6213 return false; 6214 6215 return true; 6216} 6217 6218 6219bool 6220gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) 6221{ 6222 if (!scalar_check (number, 0)) 6223 return false; 6224 if (!type_check (number, 0, BT_INTEGER)) 6225 return false; 6226 6227 if (!int_or_proc_check (handler, 1)) 6228 return false; 6229 if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) 6230 return false; 6231 6232 if (status == NULL) 6233 return true; 6234 6235 if (!type_check (status, 2, BT_INTEGER)) 6236 return false; 6237 if (!scalar_check (status, 2)) 6238 return false; 6239 6240 return true; 6241} 6242 6243 6244bool 6245gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) 6246{ 6247 if (!type_check (cmd, 0, BT_CHARACTER)) 6248 return false; 6249 if (!kind_value_check (cmd, 0, gfc_default_character_kind)) 6250 return false; 6251 6252 if (!scalar_check (status, 1)) 6253 return false; 6254 6255 if (!type_check (status, 1, BT_INTEGER)) 6256 return false; 6257 6258 if (!kind_value_check (status, 1, gfc_default_integer_kind)) 6259 return false; 6260 6261 return true; 6262} 6263 6264 6265/* This is used for the GNU intrinsics AND, OR and XOR. */ 6266bool 6267gfc_check_and (gfc_expr *i, gfc_expr *j) 6268{ 6269 if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) 6270 { 6271 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " 6272 "or LOGICAL", gfc_current_intrinsic_arg[0]->name, 6273 gfc_current_intrinsic, &i->where); 6274 return false; 6275 } 6276 6277 if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL) 6278 { 6279 gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " 6280 "or LOGICAL", gfc_current_intrinsic_arg[1]->name, 6281 gfc_current_intrinsic, &j->where); 6282 return false; 6283 } 6284 6285 if (i->ts.type != j->ts.type) 6286 { 6287 gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " 6288 "have the same type", gfc_current_intrinsic_arg[0]->name, 6289 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 6290 &j->where); 6291 return false; 6292 } 6293 6294 if (!scalar_check (i, 0)) 6295 return false; 6296 6297 if (!scalar_check (j, 1)) 6298 return false; 6299 6300 return true; 6301} 6302 6303 6304bool 6305gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) 6306{ 6307 6308 if (a->expr_type == EXPR_NULL) 6309 { 6310 gfc_error ("Intrinsic function NULL at %L cannot be an actual " 6311 "argument to STORAGE_SIZE, because it returns a " 6312 "disassociated pointer", &a->where); 6313 return false; 6314 } 6315 6316 if (a->ts.type == BT_ASSUMED) 6317 { 6318 gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", 6319 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, 6320 &a->where); 6321 return false; 6322 } 6323 6324 if (a->ts.type == BT_PROCEDURE) 6325 { 6326 gfc_error ("%qs argument of %qs intrinsic at %L shall not be a " 6327 "procedure", gfc_current_intrinsic_arg[0]->name, 6328 gfc_current_intrinsic, &a->where); 6329 return false; 6330 } 6331 6332 if (kind == NULL) 6333 return true; 6334 6335 if (!type_check (kind, 1, BT_INTEGER)) 6336 return false; 6337 6338 if (!scalar_check (kind, 1)) 6339 return false; 6340 6341 if (kind->expr_type != EXPR_CONSTANT) 6342 { 6343 gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", 6344 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, 6345 &kind->where); 6346 return false; 6347 } 6348 6349 return true; 6350} 6351