gcc/fortran/check.c

   1 /* Check functions
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22
  23 /* These functions check to see if an argument list is compatible with
  24    a particular intrinsic function or subroutine.  Presence of
  25    required arguments has already been established, the argument list
  26    has been sorted into the right order and has NULL arguments in the
  27    correct places for missing optional arguments.  */
  28
  29 #include "config.h"
  30 #include "system.h"
  31 #include "flags.h"
  32 #include "gfortran.h"
  33 #include "intrinsic.h"
  34
  35
  36 /* Make sure an expression is a scalar.  */
  37
  38 static try
  39 scalar_check (gfc_expr *e, int n)
  40 {
  41   if (e->rank == 0)
  42     return SUCCESS;
  43
  44   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
  45              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
  46
  47   return FAILURE;
  48 }
  49
  50
  51 /* Check the type of an expression.  */
  52
  53 static try
  54 type_check (gfc_expr *e, int n, bt type)
  55 {
  56   if (e->ts.type == type)
  57     return SUCCESS;
  58
  59   gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
  60              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
  61              gfc_basic_typename (type));
  62
  63   return FAILURE;
  64 }
  65
  66
  67 /* Check that the expression is a numeric type.  */
  68
  69 static try
  70 numeric_check (gfc_expr *e, int n)
  71 {
  72   if (gfc_numeric_ts (&e->ts))
  73     return SUCCESS;
  74
  75   /* If the expression has not got a type, check if its namespace can
  76      offer a default type.  */
  77   if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_VARIABLE)
  78         && e->symtree->n.sym->ts.type == BT_UNKNOWN
  79         && gfc_set_default_type (e->symtree->n.sym, 0,
  80                                  e->symtree->n.sym->ns) == SUCCESS
  81         && gfc_numeric_ts (&e->symtree->n.sym->ts))
  82     {
  83       e->ts = e->symtree->n.sym->ts;
  84       return SUCCESS;
  85     }
  86
  87   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
  88              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
  89
  90   return FAILURE;
  91 }
  92
  93
  94 /* Check that an expression is integer or real.  */
  95
  96 static try
  97 int_or_real_check (gfc_expr *e, int n)
  98 {
  99   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
 100     {
 101       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
 102                  "or REAL", gfc_current_intrinsic_arg[n],
 103                  gfc_current_intrinsic, &e->where);
 104       return FAILURE;
 105     }
 106
 107   return SUCCESS;
 108 }
 109
 110
 111 /* Check that an expression is real or complex.  */
 112
 113 static try
 114 real_or_complex_check (gfc_expr *e, int n)
 115 {
 116   if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
 117     {
 118       gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
 119                  "or COMPLEX", gfc_current_intrinsic_arg[n],
 120                  gfc_current_intrinsic, &e->where);
 121       return FAILURE;
 122     }
 123
 124   return SUCCESS;
 125 }
 126
 127
 128 /* Check that the expression is an optional constant integer
 129    and that it specifies a valid kind for that type.  */
 130
 131 static try
 132 kind_check (gfc_expr *k, int n, bt type)
 133 {
 134   int kind;
 135
 136   if (k == NULL)
 137     return SUCCESS;
 138
 139   if (type_check (k, n, BT_INTEGER) == FAILURE)
 140     return FAILURE;
 141
 142   if (scalar_check (k, n) == FAILURE)
 143     return FAILURE;
 144
 145   if (k->expr_type != EXPR_CONSTANT)
 146     {
 147       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
 148                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 149                  &k->where);
 150       return FAILURE;
 151     }
 152
 153   if (gfc_extract_int (k, &kind) != NULL
 154       || gfc_validate_kind (type, kind, true) < 0)
 155     {
 156       gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
 157                  &k->where);
 158       return FAILURE;
 159     }
 160
 161   return SUCCESS;
 162 }
 163
 164
 165 /* Make sure the expression is a double precision real.  */
 166
 167 static try
 168 double_check (gfc_expr *d, int n)
 169 {
 170   if (type_check (d, n, BT_REAL) == FAILURE)
 171     return FAILURE;
 172
 173   if (d->ts.kind != gfc_default_double_kind)
 174     {
 175       gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
 176                  "precision", gfc_current_intrinsic_arg[n],
 177                  gfc_current_intrinsic, &d->where);
 178       return FAILURE;
 179     }
 180
 181   return SUCCESS;
 182 }
 183
 184
 185 /* Make sure the expression is a logical array.  */
 186
 187 static try
 188 logical_array_check (gfc_expr *array, int n)
 189 {
 190   if (array->ts.type != BT_LOGICAL || array->rank == 0)
 191     {
 192       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
 193                  "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 194                  &array->where);
 195       return FAILURE;
 196     }
 197
 198   return SUCCESS;
 199 }
 200
 201
 202 /* Make sure an expression is an array.  */
 203
 204 static try
 205 array_check (gfc_expr *e, int n)
 206 {
 207   if (e->rank != 0)
 208     return SUCCESS;
 209
 210   gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
 211              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 212
 213   return FAILURE;
 214 }
 215
 216
 217 /* Make sure two expressions have the same type.  */
 218
 219 static try
 220 same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
 221 {
 222   if (gfc_compare_types (&e->ts, &f->ts))
 223     return SUCCESS;
 224
 225   gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
 226              "and kind as '%s'", gfc_current_intrinsic_arg[m],
 227              gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
 228
 229   return FAILURE;
 230 }
 231
 232
 233 /* Make sure that an expression has a certain (nonzero) rank.  */
 234
 235 static try
 236 rank_check (gfc_expr *e, int n, int rank)
 237 {
 238   if (e->rank == rank)
 239     return SUCCESS;
 240
 241   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
 242              gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 243              &e->where, rank);
 244
 245   return FAILURE;
 246 }
 247
 248
 249 /* Make sure a variable expression is not an optional dummy argument.  */
 250
 251 static try
 252 nonoptional_check (gfc_expr *e, int n)
 253 {
 254   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
 255     {
 256       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
 257                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 258                  &e->where);
 259     }
 260
 261   /* TODO: Recursive check on nonoptional variables?  */
 262
 263   return SUCCESS;
 264 }
 265
 266
 267 /* Check that an expression has a particular kind.  */
 268
 269 static try
 270 kind_value_check (gfc_expr *e, int n, int k)
 271 {
 272   if (e->ts.kind == k)
 273     return SUCCESS;
 274
 275   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
 276              gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 277              &e->where, k);
 278
 279   return FAILURE;
 280 }
 281
 282
 283 /* Make sure an expression is a variable.  */
 284
 285 static try
 286 variable_check (gfc_expr *e, int n)
 287 {
 288   if ((e->expr_type == EXPR_VARIABLE
 289        && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
 290       || (e->expr_type == EXPR_FUNCTION
 291           && e->symtree->n.sym->result == e->symtree->n.sym))
 292     return SUCCESS;
 293
 294   if (e->expr_type == EXPR_VARIABLE
 295       && e->symtree->n.sym->attr.intent == INTENT_IN)
 296     {
 297       gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
 298                  gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
 299                  &e->where);
 300       return FAILURE;
 301     }
 302
 303   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
 304              gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 305
 306   return FAILURE;
 307 }
 308
 309
 310 /* Check the common DIM parameter for correctness.  */
 311
 312 static try
 313 dim_check (gfc_expr *dim, int n, bool optional)
 314 {
 315   if (dim == NULL)
 316     return SUCCESS;
 317
 318   if (type_check (dim, n, BT_INTEGER) == FAILURE)
 319     return FAILURE;
 320
 321   if (scalar_check (dim, n) == FAILURE)
 322     return FAILURE;
 323
 324   if (!optional && nonoptional_check (dim, n) == FAILURE)
 325     return FAILURE;
 326
 327   return SUCCESS;
 328 }
 329
 330
 331 /* If a DIM parameter is a constant, make sure that it is greater than
 332    zero and less than or equal to the rank of the given array.  If
 333    allow_assumed is zero then dim must be less than the rank of the array
 334    for assumed size arrays.  */
 335
 336 static try
 337 dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
 338 {
 339   gfc_array_ref *ar;
 340   int rank;
 341
 342   if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
 343     return SUCCESS;
 344
 345   ar = gfc_find_array_ref (array);
 346   rank = array->rank;
 347   if (ar->as->type == AS_ASSUMED_SIZE
 348       && !allow_assumed
 349       && ar->type != AR_ELEMENT
 350       && ar->type != AR_SECTION)
 351     rank--;
 352
 353   if (mpz_cmp_ui (dim->value.integer, 1) < 0
 354       || mpz_cmp_ui (dim->value.integer, rank) > 0)
 355     {
 356       gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
 357                  "dimension index", gfc_current_intrinsic, &dim->where);
 358
 359       return FAILURE;
 360     }
 361
 362   return SUCCESS;
 363 }
 364
 365
 366 /* Compare the size of a along dimension ai with the size of b along
 367    dimension bi, returning 0 if they are known not to be identical,
 368    and 1 if they are identical, or if this cannot be determined.  */
 369
 370 static int
 371 identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 372 {
 373   mpz_t a_size, b_size;
 374   int ret;
 375
 376   gcc_assert (a->rank > ai);
 377   gcc_assert (b->rank > bi);
 378
 379   ret = 1;
 380
 381   if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
 382     {
 383       if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
 384         {
 385           if (mpz_cmp (a_size, b_size) != 0)
 386             ret = 0;
 387
 388           mpz_clear (b_size);
 389         }
 390       mpz_clear (a_size);
 391     }
 392   return ret;
 393 }
 394
 395
 396 /* Check whether two character expressions have the same length;
 397    returns SUCCESS if they have or if the length cannot be determined.  */
 398
 399 static try
 400 check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
 401 {
 402    long len_a, len_b;
 403    len_a = len_b = -1;
 404
 405    if (a->ts.cl && a->ts.cl->length
 406        && a->ts.cl->length->expr_type == EXPR_CONSTANT)
 407      len_a = mpz_get_si (a->ts.cl->length->value.integer);
 408    else if (a->expr_type == EXPR_CONSTANT
 409             && (a->ts.cl == NULL || a->ts.cl->length == NULL))
 410      len_a = a->value.character.length;
 411    else
 412      return SUCCESS;
 413
 414    if (b->ts.cl && b->ts.cl->length
 415        && b->ts.cl->length->expr_type == EXPR_CONSTANT)
 416      len_b = mpz_get_si (b->ts.cl->length->value.integer);
 417    else if (b->expr_type == EXPR_CONSTANT
 418             && (b->ts.cl == NULL || b->ts.cl->length == NULL))
 419      len_b = b->value.character.length;
 420    else
 421      return SUCCESS;
 422
 423    if (len_a == len_b)
 424      return SUCCESS;
 425
 426    gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
 427               "at %L", len_a, len_b, name, &a->where);
 428    return FAILURE;
 429 }
 430
 431
 432 /***** Check functions *****/
 433
 434 /* Check subroutine suitable for intrinsics taking a real argument and
 435    a kind argument for the result.  */
 436
 437 static try
 438 check_a_kind (gfc_expr *a, gfc_expr *kind, bt type)
 439 {
 440   if (type_check (a, 0, BT_REAL) == FAILURE)
 441     return FAILURE;
 442   if (kind_check (kind, 1, type) == FAILURE)
 443     return FAILURE;
 444
 445   return SUCCESS;
 446 }
 447
 448
 449 /* Check subroutine suitable for ceiling, floor and nint.  */
 450
 451 try
 452 gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind)
 453 {
 454   return check_a_kind (a, kind, BT_INTEGER);
 455 }
 456
 457
 458 /* Check subroutine suitable for aint, anint.  */
 459
 460 try
 461 gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind)
 462 {
 463   return check_a_kind (a, kind, BT_REAL);
 464 }
 465
 466
 467 try
 468 gfc_check_abs (gfc_expr *a)
 469 {
 470   if (numeric_check (a, 0) == FAILURE)
 471     return FAILURE;
 472
 473   return SUCCESS;
 474 }
 475
 476
 477 try
 478 gfc_check_achar (gfc_expr *a, gfc_expr *kind)
 479 {
 480   if (type_check (a, 0, BT_INTEGER) == FAILURE)
 481     return FAILURE;
 482   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 483     return FAILURE;
 484
 485   return SUCCESS;
 486 }
 487
 488
 489 try
 490 gfc_check_access_func (gfc_expr *name, gfc_expr *mode)
 491 {
 492   if (type_check (name, 0, BT_CHARACTER) == FAILURE
 493       || scalar_check (name, 0) == FAILURE)
 494     return FAILURE;
 495
 496   if (type_check (mode, 1, BT_CHARACTER) == FAILURE
 497       || scalar_check (mode, 1) == FAILURE)
 498     return FAILURE;
 499
 500   return SUCCESS;
 501 }
 502
 503
 504 try
 505 gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
 506 {
 507   if (logical_array_check (mask, 0) == FAILURE)
 508     return FAILURE;
 509
 510   if (dim_check (dim, 1, false) == FAILURE)
 511     return FAILURE;
 512
 513   return SUCCESS;
 514 }
 515
 516
 517 try
 518 gfc_check_allocated (gfc_expr *array)
 519 {
 520   symbol_attribute attr;
 521
 522   if (variable_check (array, 0) == FAILURE)
 523     return FAILURE;
 524
 525   attr = gfc_variable_attr (array, NULL);
 526   if (!attr.allocatable)
 527     {
 528       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
 529                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 530                  &array->where);
 531       return FAILURE;
 532     }
 533
 534   if (array_check (array, 0) == FAILURE)
 535     return FAILURE;
 536
 537   return SUCCESS;
 538 }
 539
 540
 541 /* Common check function where the first argument must be real or
 542    integer and the second argument must be the same as the first.  */
 543
 544 try
 545 gfc_check_a_p (gfc_expr *a, gfc_expr *p)
 546 {
 547   if (int_or_real_check (a, 0) == FAILURE)
 548     return FAILURE;
 549
 550   if (a->ts.type != p->ts.type)
 551     {
 552       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
 553                  "have the same type", gfc_current_intrinsic_arg[0],
 554                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
 555                  &p->where);
 556       return FAILURE;
 557     }
 558
 559   if (a->ts.kind != p->ts.kind)
 560     {
 561       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
 562                           &p->where) == FAILURE)
 563        return FAILURE;
 564     }
 565
 566   return SUCCESS;
 567 }
 568
 569
 570 try
 571 gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
 572 {
 573   if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE)
 574     return FAILURE;
 575
 576   return SUCCESS;
 577 }
 578
 579
 580 try
 581 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
 582 {
 583   symbol_attribute attr;
 584   int i;
 585   try t;
 586   locus *where;
 587
 588   where = &pointer->where;
 589
 590   if (pointer->expr_type == EXPR_VARIABLE)
 591     attr = gfc_variable_attr (pointer, NULL);
 592   else if (pointer->expr_type == EXPR_FUNCTION)
 593     attr = pointer->symtree->n.sym->attr;
 594   else if (pointer->expr_type == EXPR_NULL)
 595     goto null_arg;
 596   else
 597     gcc_assert (0); /* Pointer must be a variable or a function.  */
 598
 599   if (!attr.pointer)
 600     {
 601       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
 602                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
 603                  &pointer->where);
 604       return FAILURE;
 605     }
 606
 607   /* Target argument is optional.  */
 608   if (target == NULL)
 609     return SUCCESS;
 610
 611   where = &target->where;
 612   if (target->expr_type == EXPR_NULL)
 613     goto null_arg;
 614
 615   if (target->expr_type == EXPR_VARIABLE)
 616     attr = gfc_variable_attr (target, NULL);
 617   else if (target->expr_type == EXPR_FUNCTION)
 618     attr = target->symtree->n.sym->attr;
 619   else
 620     {
 621       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
 622                  "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
 623                  gfc_current_intrinsic, &target->where);
 624       return FAILURE;
 625     }
 626
 627   if (!attr.pointer && !attr.target)
 628     {
 629       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
 630                  "or a TARGET", gfc_current_intrinsic_arg[1],
 631                  gfc_current_intrinsic, &target->where);
 632       return FAILURE;
 633     }
 634
 635   t = SUCCESS;
 636   if (same_type_check (pointer, 0, target, 1) == FAILURE)
 637     t = FAILURE;
 638   if (rank_check (target, 0, pointer->rank) == FAILURE)
 639     t = FAILURE;
 640   if (target->rank > 0)
 641     {
 642       for (i = 0; i < target->rank; i++)
 643         if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 644           {
 645             gfc_error ("Array section with a vector subscript at %L shall not "
 646                        "be the target of a pointer",
 647                        &target->where);
 648             t = FAILURE;
 649             break;
 650           }
 651     }
 652   return t;
 653
 654 null_arg:
 655
 656   gfc_error ("NULL pointer at %L is not permitted as actual argument "
 657              "of '%s' intrinsic function", where, gfc_current_intrinsic);
 658   return FAILURE;
 659
 660 }
 661
 662
 663 try
 664 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
 665 {
 666   if (type_check (y, 0, BT_REAL) == FAILURE)
 667     return FAILURE;
 668   if (same_type_check (y, 0, x, 1) == FAILURE)
 669     return FAILURE;
 670
 671   return SUCCESS;
 672 }
 673
 674
 675 /* BESJN and BESYN functions.  */
 676
 677 try
 678 gfc_check_besn (gfc_expr *n, gfc_expr *x)
 679 {
 680   if (type_check (n, 0, BT_INTEGER) == FAILURE)
 681     return FAILURE;
 682
 683   if (type_check (x, 1, BT_REAL) == FAILURE)
 684     return FAILURE;
 685
 686   return SUCCESS;
 687 }
 688
 689
 690 try
 691 gfc_check_btest (gfc_expr *i, gfc_expr *pos)
 692 {
 693   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 694     return FAILURE;
 695   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
 696     return FAILURE;
 697
 698   return SUCCESS;
 699 }
 700
 701
 702 try
 703 gfc_check_char (gfc_expr *i, gfc_expr *kind)
 704 {
 705   if (type_check (i, 0, BT_INTEGER) == FAILURE)
 706     return FAILURE;
 707   if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
 708     return FAILURE;
 709
 710   return SUCCESS;
 711 }
 712
 713
 714 try
 715 gfc_check_chdir (gfc_expr *dir)
 716 {
 717   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
 718     return FAILURE;
 719
 720   return SUCCESS;
 721 }
 722
 723
 724 try
 725 gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status)
 726 {
 727   if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
 728     return FAILURE;
 729
 730   if (status == NULL)
 731     return SUCCESS;
 732
 733   if (type_check (status, 1, BT_INTEGER) == FAILURE)
 734     return FAILURE;
 735
 736   if (scalar_check (status, 1) == FAILURE)
 737     return FAILURE;
 738
 739   return SUCCESS;
 740 }
 741
 742
 743 try
 744 gfc_check_chmod (gfc_expr *name, gfc_expr *mode)
 745 {
 746   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
 747     return FAILURE;
 748
 749   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
 750     return FAILURE;
 751
 752   return SUCCESS;
 753 }
 754
 755
 756 try
 757 gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status)
 758 {
 759   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
 760     return FAILURE;
 761
 762   if (type_check (mode, 1, BT_CHARACTER) == FAILURE)
 763     return FAILURE;
 764
 765   if (status == NULL)
 766     return SUCCESS;
 767
 768   if (type_check (status, 2, BT_INTEGER) == FAILURE)
 769     return FAILURE;
 770
 771   if (scalar_check (status, 2) == FAILURE)
 772     return FAILURE;
 773
 774   return SUCCESS;
 775 }
 776
 777
 778 try
 779 gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
 780 {
 781   if (numeric_check (x, 0) == FAILURE)
 782     return FAILURE;
 783
 784   if (y != NULL)
 785     {
 786       if (numeric_check (y, 1) == FAILURE)
 787         return FAILURE;
 788
 789       if (x->ts.type == BT_COMPLEX)
 790         {
 791           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 792                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 793                      gfc_current_intrinsic, &y->where);
 794           return FAILURE;
 795         }
 796     }
 797
 798   if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
 799     return FAILURE;
 800
 801   return SUCCESS;
 802 }
 803
 804
 805 try
 806 gfc_check_complex (gfc_expr *x, gfc_expr *y)
 807 {
 808   if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
 809     {
 810       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
 811                  "or REAL", gfc_current_intrinsic_arg[0],
 812                  gfc_current_intrinsic, &x->where);
 813       return FAILURE;
 814     }
 815   if (scalar_check (x, 0) == FAILURE)
 816     return FAILURE;
 817
 818   if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
 819     {
 820       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
 821                  "or REAL", gfc_current_intrinsic_arg[1],
 822                  gfc_current_intrinsic, &y->where);
 823       return FAILURE;
 824     }
 825   if (scalar_check (y, 1) == FAILURE)
 826     return FAILURE;
 827
 828   return SUCCESS;
 829 }
 830
 831
 832 try
 833 gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 834 {
 835   if (logical_array_check (mask, 0) == FAILURE)
 836     return FAILURE;
 837   if (dim_check (dim, 1, false) == FAILURE)
 838     return FAILURE;
 839   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
 840     return FAILURE;
 841   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
 842                               "with KIND argument at %L",
 843                               gfc_current_intrinsic, &kind->where) == FAILURE)
 844     return FAILURE;
 845
 846   return SUCCESS;
 847 }
 848
 849
 850 try
 851 gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
 852 {
 853   if (array_check (array, 0) == FAILURE)
 854     return FAILURE;
 855
 856   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
 857     return FAILURE;
 858
 859   if (array->rank == 1)
 860     {
 861       if (scalar_check (shift, 1) == FAILURE)
 862         return FAILURE;
 863     }
 864   else
 865     {
 866       /* TODO: more requirements on shift parameter.  */
 867     }
 868
 869   if (dim_check (dim, 2, true) == FAILURE)
 870     return FAILURE;
 871
 872   return SUCCESS;
 873 }
 874
 875
 876 try
 877 gfc_check_ctime (gfc_expr *time)
 878 {
 879   if (scalar_check (time, 0) == FAILURE)
 880     return FAILURE;
 881
 882   if (type_check (time, 0, BT_INTEGER) == FAILURE)
 883     return FAILURE;
 884
 885   return SUCCESS;
 886 }
 887
 888
 889 try gfc_check_datan2 (gfc_expr *y, gfc_expr *x)
 890 {
 891   if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE)
 892     return FAILURE;
 893
 894   return SUCCESS;
 895 }
 896
 897 try
 898 gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
 899 {
 900   if (numeric_check (x, 0) == FAILURE)
 901     return FAILURE;
 902
 903   if (y != NULL)
 904     {
 905       if (numeric_check (y, 1) == FAILURE)
 906         return FAILURE;
 907
 908       if (x->ts.type == BT_COMPLEX)
 909         {
 910           gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
 911                      "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
 912                      gfc_current_intrinsic, &y->where);
 913           return FAILURE;
 914         }
 915     }
 916
 917   return SUCCESS;
 918 }
 919
 920
 921 try
 922 gfc_check_dble (gfc_expr *x)
 923 {
 924   if (numeric_check (x, 0) == FAILURE)
 925     return FAILURE;
 926
 927   return SUCCESS;
 928 }
 929
 930
 931 try
 932 gfc_check_digits (gfc_expr *x)
 933 {
 934   if (int_or_real_check (x, 0) == FAILURE)
 935     return FAILURE;
 936
 937   return SUCCESS;
 938 }
 939
 940
 941 try
 942 gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
 943 {
 944   switch (vector_a->ts.type)
 945     {
 946     case BT_LOGICAL:
 947       if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
 948         return FAILURE;
 949       break;
 950
 951     case BT_INTEGER:
 952     case BT_REAL:
 953     case BT_COMPLEX:
 954       if (numeric_check (vector_b, 1) == FAILURE)
 955         return FAILURE;
 956       break;
 957
 958     default:
 959       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
 960                  "or LOGICAL", gfc_current_intrinsic_arg[0],
 961                  gfc_current_intrinsic, &vector_a->where);
 962       return FAILURE;
 963     }
 964
 965   if (rank_check (vector_a, 0, 1) == FAILURE)
 966     return FAILURE;
 967
 968   if (rank_check (vector_b, 1, 1) == FAILURE)
 969     return FAILURE;
 970
 971   if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
 972     {
 973       gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
 974                  "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
 975                  gfc_current_intrinsic_arg[1], &vector_a->where);
 976       return FAILURE;
 977     }
 978
 979   return SUCCESS;
 980 }
 981
 982
 983 try
 984 gfc_check_dprod (gfc_expr *x, gfc_expr *y)
 985 {
 986   if (type_check (x, 0, BT_REAL) == FAILURE
 987       || type_check (y, 1, BT_REAL) == FAILURE)
 988     return FAILURE;
 989
 990   if (x->ts.kind != gfc_default_real_kind)
 991     {
 992       gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
 993                  "real", gfc_current_intrinsic_arg[0],
 994                  gfc_current_intrinsic, &x->where);
 995       return FAILURE;
 996     }
 997
 998   if (y->ts.kind != gfc_default_real_kind)
 999     {
1000       gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
1001                  "real", gfc_current_intrinsic_arg[1],
1002                  gfc_current_intrinsic, &y->where);
1003       return FAILURE;
1004     }
1005
1006   return SUCCESS;
1007 }
1008
1009
1010 try
1011 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
1012                    gfc_expr *dim)
1013 {
1014   if (array_check (array, 0) == FAILURE)
1015     return FAILURE;
1016
1017   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
1018     return FAILURE;
1019
1020   if (array->rank == 1)
1021     {
1022       if (scalar_check (shift, 2) == FAILURE)
1023         return FAILURE;
1024     }
1025   else
1026     {
1027       /* TODO: more weird restrictions on shift.  */
1028     }
1029
1030   if (boundary != NULL)
1031     {
1032       if (same_type_check (array, 0, boundary, 2) == FAILURE)
1033         return FAILURE;
1034
1035       /* TODO: more restrictions on boundary.  */
1036     }
1037
1038   if (dim_check (dim, 4, true) == FAILURE)
1039     return FAILURE;
1040
1041   return SUCCESS;
1042 }
1043
1044
1045 /* A single complex argument.  */
1046
1047 try
1048 gfc_check_fn_c (gfc_expr *a)
1049 {
1050   if (type_check (a, 0, BT_COMPLEX) == FAILURE)
1051     return FAILURE;
1052
1053   return SUCCESS;
1054 }
1055
1056
1057 /* A single real argument.  */
1058
1059 try
1060 gfc_check_fn_r (gfc_expr *a)
1061 {
1062   if (type_check (a, 0, BT_REAL) == FAILURE)
1063     return FAILURE;
1064
1065   return SUCCESS;
1066 }
1067
1068 /* A single double argument.  */
1069
1070 try
1071 gfc_check_fn_d (gfc_expr *a)
1072 {
1073   if (double_check (a, 0) == FAILURE)
1074     return FAILURE;
1075
1076   return SUCCESS;
1077 }
1078
1079 /* A single real or complex argument.  */
1080
1081 try
1082 gfc_check_fn_rc (gfc_expr *a)
1083 {
1084   if (real_or_complex_check (a, 0) == FAILURE)
1085     return FAILURE;
1086
1087   return SUCCESS;
1088 }
1089
1090
1091 try
1092 gfc_check_fnum (gfc_expr *unit)
1093 {
1094   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
1095     return FAILURE;
1096
1097   if (scalar_check (unit, 0) == FAILURE)
1098     return FAILURE;
1099
1100   return SUCCESS;
1101 }
1102
1103
1104 try
1105 gfc_check_huge (gfc_expr *x)
1106 {
1107   if (int_or_real_check (x, 0) == FAILURE)
1108     return FAILURE;
1109
1110   return SUCCESS;
1111 }
1112
1113
1114 try
1115 gfc_check_hypot (gfc_expr *x, gfc_expr *y)
1116 {
1117   if (type_check (x, 0, BT_REAL) == FAILURE)
1118     return FAILURE;
1119   if (same_type_check (x, 0, y, 1) == FAILURE)
1120     return FAILURE;
1121
1122   return SUCCESS;
1123 }
1124
1125
1126 /* Check that the single argument is an integer.  */
1127
1128 try
1129 gfc_check_i (gfc_expr *i)
1130 {
1131   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1132     return FAILURE;
1133
1134   return SUCCESS;
1135 }
1136
1137
1138 try
1139 gfc_check_iand (gfc_expr *i, gfc_expr *j)
1140 {
1141   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1142     return FAILURE;
1143
1144   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1145     return FAILURE;
1146
1147   if (i->ts.kind != j->ts.kind)
1148     {
1149       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1150                           &i->where) == FAILURE)
1151         return FAILURE;
1152     }
1153
1154   return SUCCESS;
1155 }
1156
1157
1158 try
1159 gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
1160 {
1161   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1162     return FAILURE;
1163
1164   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1165     return FAILURE;
1166
1167   return SUCCESS;
1168 }
1169
1170
1171 try
1172 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
1173 {
1174   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1175     return FAILURE;
1176
1177   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1178     return FAILURE;
1179
1180   if (type_check (len, 2, BT_INTEGER) == FAILURE)
1181     return FAILURE;
1182
1183   return SUCCESS;
1184 }
1185
1186
1187 try
1188 gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
1189 {
1190   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1191     return FAILURE;
1192
1193   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
1194     return FAILURE;
1195
1196   return SUCCESS;
1197 }
1198
1199
1200 try
1201 gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
1202 {
1203   int i;
1204
1205   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
1206     return FAILURE;
1207
1208   if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1209     return FAILURE;
1210
1211   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1212                               "with KIND argument at %L",
1213                               gfc_current_intrinsic, &kind->where) == FAILURE)
1214     return FAILURE;
1215
1216   if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
1217     {
1218       gfc_expr *start;
1219       gfc_expr *end;
1220       gfc_ref *ref;
1221
1222       /* Substring references don't have the charlength set.  */
1223       ref = c->ref;
1224       while (ref && ref->type != REF_SUBSTRING)
1225         ref = ref->next;
1226
1227       gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
1228
1229       if (!ref)
1230         {
1231           /* Check that the argument is length one.  Non-constant lengths
1232              can't be checked here, so assume they are ok.  */
1233           if (c->ts.cl && c->ts.cl->length)
1234             {
1235               /* If we already have a length for this expression then use it.  */
1236               if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
1237                 return SUCCESS;
1238               i = mpz_get_si (c->ts.cl->length->value.integer);
1239             }
1240           else
1241             return SUCCESS;
1242         }
1243       else
1244         {
1245           start = ref->u.ss.start;
1246           end = ref->u.ss.end;
1247
1248           gcc_assert (start);
1249           if (end == NULL || end->expr_type != EXPR_CONSTANT
1250               || start->expr_type != EXPR_CONSTANT)
1251             return SUCCESS;
1252
1253           i = mpz_get_si (end->value.integer) + 1
1254             - mpz_get_si (start->value.integer);
1255         }
1256     }
1257   else
1258     return SUCCESS;
1259
1260   if (i != 1)
1261     {
1262       gfc_error ("Argument of %s at %L must be of length one",
1263                  gfc_current_intrinsic, &c->where);
1264       return FAILURE;
1265     }
1266
1267   return SUCCESS;
1268 }
1269
1270
1271 try
1272 gfc_check_idnint (gfc_expr *a)
1273 {
1274   if (double_check (a, 0) == FAILURE)
1275     return FAILURE;
1276
1277   return SUCCESS;
1278 }
1279
1280
1281 try
1282 gfc_check_ieor (gfc_expr *i, gfc_expr *j)
1283 {
1284   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1285     return FAILURE;
1286
1287   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1288     return FAILURE;
1289
1290   if (i->ts.kind != j->ts.kind)
1291     {
1292       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1293                           &i->where) == FAILURE)
1294         return FAILURE;
1295     }
1296
1297   return SUCCESS;
1298 }
1299
1300
1301 try
1302 gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
1303                  gfc_expr *kind)
1304 {
1305   if (type_check (string, 0, BT_CHARACTER) == FAILURE
1306       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
1307     return FAILURE;
1308
1309   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
1310     return FAILURE;
1311
1312   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
1313     return FAILURE;
1314   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1315                               "with KIND argument at %L",
1316                               gfc_current_intrinsic, &kind->where) == FAILURE)
1317     return FAILURE;
1318
1319   if (string->ts.kind != substring->ts.kind)
1320     {
1321       gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
1322                  "kind as '%s'", gfc_current_intrinsic_arg[1],
1323                  gfc_current_intrinsic, &substring->where,
1324                  gfc_current_intrinsic_arg[0]);
1325       return FAILURE;
1326     }
1327
1328   return SUCCESS;
1329 }
1330
1331
1332 try
1333 gfc_check_int (gfc_expr *x, gfc_expr *kind)
1334 {
1335   if (numeric_check (x, 0) == FAILURE)
1336     return FAILURE;
1337
1338   if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1339     return FAILURE;
1340
1341   return SUCCESS;
1342 }
1343
1344
1345 try
1346 gfc_check_intconv (gfc_expr *x)
1347 {
1348   if (numeric_check (x, 0) == FAILURE)
1349     return FAILURE;
1350
1351   return SUCCESS;
1352 }
1353
1354
1355 try
1356 gfc_check_ior (gfc_expr *i, gfc_expr *j)
1357 {
1358   if (type_check (i, 0, BT_INTEGER) == FAILURE)
1359     return FAILURE;
1360
1361   if (type_check (j, 1, BT_INTEGER) == FAILURE)
1362     return FAILURE;
1363
1364   if (i->ts.kind != j->ts.kind)
1365     {
1366       if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
1367                           &i->where) == FAILURE)
1368         return FAILURE;
1369     }
1370
1371   return SUCCESS;
1372 }
1373
1374
1375 try
1376 gfc_check_ishft (gfc_expr *i, gfc_expr *shift)
1377 {
1378   if (type_check (i, 0, BT_INTEGER) == FAILURE
1379       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1380     return FAILURE;
1381
1382   return SUCCESS;
1383 }
1384
1385
1386 try
1387 gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1388 {
1389   if (type_check (i, 0, BT_INTEGER) == FAILURE
1390       || type_check (shift, 1, BT_INTEGER) == FAILURE)
1391     return FAILURE;
1392
1393   if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
1394     return FAILURE;
1395
1396   return SUCCESS;
1397 }
1398
1399
1400 try
1401 gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
1402 {
1403   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1404     return FAILURE;
1405
1406   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1407     return FAILURE;
1408
1409   return SUCCESS;
1410 }
1411
1412
1413 try
1414 gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
1415 {
1416   if (type_check (pid, 0, BT_INTEGER) == FAILURE)
1417     return FAILURE;
1418
1419   if (scalar_check (pid, 0) == FAILURE)
1420     return FAILURE;
1421
1422   if (type_check (sig, 1, BT_INTEGER) == FAILURE)
1423     return FAILURE;
1424
1425   if (scalar_check (sig, 1) == FAILURE)
1426     return FAILURE;
1427
1428   if (status == NULL)
1429     return SUCCESS;
1430
1431   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1432     return FAILURE;
1433
1434   if (scalar_check (status, 2) == FAILURE)
1435     return FAILURE;
1436
1437   return SUCCESS;
1438 }
1439
1440
1441 try
1442 gfc_check_kind (gfc_expr *x)
1443 {
1444   if (x->ts.type == BT_DERIVED)
1445     {
1446       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
1447                  "non-derived type", gfc_current_intrinsic_arg[0],
1448                  gfc_current_intrinsic, &x->where);
1449       return FAILURE;
1450     }
1451
1452   return SUCCESS;
1453 }
1454
1455
1456 try
1457 gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1458 {
1459   if (array_check (array, 0) == FAILURE)
1460     return FAILURE;
1461
1462   if (dim != NULL)
1463     {
1464       if (dim_check (dim, 1, false) == FAILURE)
1465         return FAILURE;
1466
1467       if (dim_rank_check (dim, array, 1) == FAILURE)
1468         return FAILURE;
1469     }
1470
1471   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
1472     return FAILURE;
1473   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1474                               "with KIND argument at %L",
1475                               gfc_current_intrinsic, &kind->where) == FAILURE)
1476     return FAILURE;
1477
1478   return SUCCESS;
1479 }
1480
1481
1482 try
1483 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
1484 {
1485   if (type_check (s, 0, BT_CHARACTER) == FAILURE)
1486     return FAILURE;
1487
1488   if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
1489     return FAILURE;
1490   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1491                               "with KIND argument at %L",
1492                               gfc_current_intrinsic, &kind->where) == FAILURE)
1493     return FAILURE;
1494
1495   return SUCCESS;
1496 }
1497
1498
1499 try
1500 gfc_check_link (gfc_expr *path1, gfc_expr *path2)
1501 {
1502   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1503     return FAILURE;
1504
1505   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1506     return FAILURE;
1507
1508   return SUCCESS;
1509 }
1510
1511
1512 try
1513 gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1514 {
1515   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1516     return FAILURE;
1517
1518   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1519     return FAILURE;
1520
1521   if (status == NULL)
1522     return SUCCESS;
1523
1524   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1525     return FAILURE;
1526
1527   if (scalar_check (status, 2) == FAILURE)
1528     return FAILURE;
1529
1530   return SUCCESS;
1531 }
1532
1533
1534 try
1535 gfc_check_loc (gfc_expr *expr)
1536 {
1537   return variable_check (expr, 0);
1538 }
1539
1540
1541 try
1542 gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2)
1543 {
1544   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1545     return FAILURE;
1546
1547   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1548     return FAILURE;
1549
1550   return SUCCESS;
1551 }
1552
1553
1554 try
1555 gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
1556 {
1557   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
1558     return FAILURE;
1559
1560   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
1561     return FAILURE;
1562
1563   if (status == NULL)
1564     return SUCCESS;
1565
1566   if (type_check (status, 2, BT_INTEGER) == FAILURE)
1567     return FAILURE;
1568
1569   if (scalar_check (status, 2) == FAILURE)
1570     return FAILURE;
1571
1572   return SUCCESS;
1573 }
1574
1575
1576 try
1577 gfc_check_logical (gfc_expr *a, gfc_expr *kind)
1578 {
1579   if (type_check (a, 0, BT_LOGICAL) == FAILURE)
1580     return FAILURE;
1581   if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
1582     return FAILURE;
1583
1584   return SUCCESS;
1585 }
1586
1587
1588 /* Min/max family.  */
1589
1590 static try
1591 min_max_args (gfc_actual_arglist *arg)
1592 {
1593   if (arg == NULL || arg->next == NULL)
1594     {
1595       gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
1596                  gfc_current_intrinsic, gfc_current_intrinsic_where);
1597       return FAILURE;
1598     }
1599
1600   return SUCCESS;
1601 }
1602
1603
1604 static try
1605 check_rest (bt type, int kind, gfc_actual_arglist *arglist)
1606 {
1607   gfc_actual_arglist *arg, *tmp;
1608
1609   gfc_expr *x;
1610   int m, n;
1611
1612   if (min_max_args (arglist) == FAILURE)
1613     return FAILURE;
1614
1615   for (arg = arglist, n=1; arg; arg = arg->next, n++)
1616     {
1617       x = arg->expr;
1618       if (x->ts.type != type || x->ts.kind != kind)
1619         {
1620           if (x->ts.type == type)
1621             {
1622               if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type "
1623                                   "kinds at %L", &x->where) == FAILURE)
1624                 return FAILURE;
1625             }
1626           else
1627             {
1628               gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
1629                          "%s(%d)", n, gfc_current_intrinsic, &x->where,
1630                          gfc_basic_typename (type), kind);
1631               return FAILURE;
1632             }
1633         }
1634
1635       for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
1636         {
1637           char buffer[80];
1638           snprintf (buffer, 80, "arguments 'a%d' and 'a%d' for intrinsic '%s'",
1639                     m, n, gfc_current_intrinsic);
1640           if (gfc_check_conformance (buffer, tmp->expr, x) == FAILURE)
1641             return FAILURE;
1642         }
1643     }
1644
1645   return SUCCESS;
1646 }
1647
1648
1649 try
1650 gfc_check_min_max (gfc_actual_arglist *arg)
1651 {
1652   gfc_expr *x;
1653
1654   if (min_max_args (arg) == FAILURE)
1655     return FAILURE;
1656
1657   x = arg->expr;
1658
1659   if (x->ts.type == BT_CHARACTER)
1660     {
1661       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
1662                           "with CHARACTER argument at %L",
1663                           gfc_current_intrinsic, &x->where) == FAILURE)
1664         return FAILURE;
1665     }
1666   else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
1667     {
1668       gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
1669                  "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
1670       return FAILURE;
1671     }
1672
1673   return check_rest (x->ts.type, x->ts.kind, arg);
1674 }
1675
1676
1677 try
1678 gfc_check_min_max_integer (gfc_actual_arglist *arg)
1679 {
1680   return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
1681 }
1682
1683
1684 try
1685 gfc_check_min_max_real (gfc_actual_arglist *arg)
1686 {
1687   return check_rest (BT_REAL, gfc_default_real_kind, arg);
1688 }
1689
1690
1691 try
1692 gfc_check_min_max_double (gfc_actual_arglist *arg)
1693 {
1694   return check_rest (BT_REAL, gfc_default_double_kind, arg);
1695 }
1696
1697
1698 /* End of min/max family.  */
1699
1700 try
1701 gfc_check_malloc (gfc_expr *size)
1702 {
1703   if (type_check (size, 0, BT_INTEGER) == FAILURE)
1704     return FAILURE;
1705
1706   if (scalar_check (size, 0) == FAILURE)
1707     return FAILURE;
1708
1709   return SUCCESS;
1710 }
1711
1712
1713 try
1714 gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
1715 {
1716   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
1717     {
1718       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1719                  "or LOGICAL", gfc_current_intrinsic_arg[0],
1720                  gfc_current_intrinsic, &matrix_a->where);
1721       return FAILURE;
1722     }
1723
1724   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
1725     {
1726       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
1727                  "or LOGICAL", gfc_current_intrinsic_arg[1],
1728                  gfc_current_intrinsic, &matrix_b->where);
1729       return FAILURE;
1730     }
1731
1732   switch (matrix_a->rank)
1733     {
1734     case 1:
1735       if (rank_check (matrix_b, 1, 2) == FAILURE)
1736         return FAILURE;
1737       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
1738       if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
1739         {
1740           gfc_error ("Different shape on dimension 1 for arguments '%s' "
1741                      "and '%s' at %L for intrinsic matmul",
1742                      gfc_current_intrinsic_arg[0],
1743                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1744           return FAILURE;
1745         }
1746       break;
1747
1748     case 2:
1749       if (matrix_b->rank != 2)
1750         {
1751           if (rank_check (matrix_b, 1, 1) == FAILURE)
1752             return FAILURE;
1753         }
1754       /* matrix_b has rank 1 or 2 here. Common check for the cases
1755          - matrix_a has shape (n,m) and matrix_b has shape (m, k)
1756          - matrix_a has shape (n,m) and matrix_b has shape (m).  */
1757       if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
1758         {
1759           gfc_error ("Different shape on dimension 2 for argument '%s' and "
1760                      "dimension 1 for argument '%s' at %L for intrinsic "
1761                      "matmul", gfc_current_intrinsic_arg[0],
1762                      gfc_current_intrinsic_arg[1], &matrix_a->where);
1763           return FAILURE;
1764         }
1765       break;
1766
1767     default:
1768       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
1769                  "1 or 2", gfc_current_intrinsic_arg[0],
1770                  gfc_current_intrinsic, &matrix_a->where);
1771       return FAILURE;
1772     }
1773
1774   return SUCCESS;
1775 }
1776
1777
1778 /* Whoever came up with this interface was probably on something.
1779    The possibilities for the occupation of the second and third
1780    parameters are:
1781
1782          Arg #2     Arg #3
1783          NULL       NULL
1784          DIM    NULL
1785          MASK       NULL
1786          NULL       MASK             minloc(array, mask=m)
1787          DIM    MASK
1788
1789    I.e. in the case of minloc(array,mask), mask will be in the second
1790    position of the argument list and we'll have to fix that up.  */
1791
1792 try
1793 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
1794 {
1795   gfc_expr *a, *m, *d;
1796
1797   a = ap->expr;
1798   if (int_or_real_check (a, 0) == FAILURE || array_check (a, 0) == FAILURE)
1799     return FAILURE;
1800
1801   d = ap->next->expr;
1802   m = ap->next->next->expr;
1803
1804   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1805       && ap->next->name == NULL)
1806     {
1807       m = d;
1808       d = NULL;
1809       ap->next->expr = NULL;
1810       ap->next->next->expr = m;
1811     }
1812
1813   if (d && dim_check (d, 1, false) == FAILURE)
1814     return FAILURE;
1815
1816   if (d && dim_rank_check (d, a, 0) == FAILURE)
1817     return FAILURE;
1818
1819   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1820     return FAILURE;
1821
1822   if (m != NULL)
1823     {
1824       char buffer[80];
1825       snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1826                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1827                 gfc_current_intrinsic);
1828       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1829         return FAILURE;
1830     }
1831
1832   return SUCCESS;
1833 }
1834
1835
1836 /* Similar to minloc/maxloc, the argument list might need to be
1837    reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
1838    difference is that MINLOC/MAXLOC take an additional KIND argument.
1839    The possibilities are:
1840
1841          Arg #2     Arg #3
1842          NULL       NULL
1843          DIM    NULL
1844          MASK       NULL
1845          NULL       MASK             minval(array, mask=m)
1846          DIM    MASK
1847
1848    I.e. in the case of minval(array,mask), mask will be in the second
1849    position of the argument list and we'll have to fix that up.  */
1850
1851 static try
1852 check_reduction (gfc_actual_arglist *ap)
1853 {
1854   gfc_expr *a, *m, *d;
1855
1856   a = ap->expr;
1857   d = ap->next->expr;
1858   m = ap->next->next->expr;
1859
1860   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
1861       && ap->next->name == NULL)
1862     {
1863       m = d;
1864       d = NULL;
1865       ap->next->expr = NULL;
1866       ap->next->next->expr = m;
1867     }
1868
1869   if (d && dim_check (d, 1, false) == FAILURE)
1870     return FAILURE;
1871
1872   if (d && dim_rank_check (d, a, 0) == FAILURE)
1873     return FAILURE;
1874
1875   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
1876     return FAILURE;
1877
1878   if (m != NULL)
1879     {
1880       char buffer[80];
1881       snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
1882                 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
1883                 gfc_current_intrinsic);
1884       if (gfc_check_conformance (buffer, a, m) == FAILURE)
1885         return FAILURE;
1886     }
1887
1888   return SUCCESS;
1889 }
1890
1891
1892 try
1893 gfc_check_minval_maxval (gfc_actual_arglist *ap)
1894 {
1895   if (int_or_real_check (ap->expr, 0) == FAILURE
1896       || array_check (ap->expr, 0) == FAILURE)
1897     return FAILURE;
1898
1899   return check_reduction (ap);
1900 }
1901
1902
1903 try
1904 gfc_check_product_sum (gfc_actual_arglist *ap)
1905 {
1906   if (numeric_check (ap->expr, 0) == FAILURE
1907       || array_check (ap->expr, 0) == FAILURE)
1908     return FAILURE;
1909
1910   return check_reduction (ap);
1911 }
1912
1913
1914 try
1915 gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
1916 {
1917   if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
1918     return FAILURE;
1919
1920   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
1921     return FAILURE;
1922
1923   if (tsource->ts.type == BT_CHARACTER)
1924     return check_same_strlen (tsource, fsource, "MERGE");
1925
1926   return SUCCESS;
1927 }
1928
1929
1930 try
1931 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
1932 {
1933   symbol_attribute attr;
1934
1935   if (variable_check (from, 0) == FAILURE)
1936     return FAILURE;
1937
1938   if (array_check (from, 0) == FAILURE)
1939     return FAILURE;
1940
1941   attr = gfc_variable_attr (from, NULL);
1942   if (!attr.allocatable)
1943     {
1944       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1945                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1946                  &from->where);
1947       return FAILURE;
1948     }
1949
1950   if (variable_check (to, 0) == FAILURE)
1951     return FAILURE;
1952
1953   if (array_check (to, 0) == FAILURE)
1954     return FAILURE;
1955
1956   attr = gfc_variable_attr (to, NULL);
1957   if (!attr.allocatable)
1958     {
1959       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1960                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1961                  &to->where);
1962       return FAILURE;
1963     }
1964
1965   if (same_type_check (from, 0, to, 1) == FAILURE)
1966     return FAILURE;
1967
1968   if (to->rank != from->rank)
1969     {
1970       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1971                  "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1972                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1973                  &to->where,  from->rank, to->rank);
1974       return FAILURE;
1975     }
1976
1977   if (to->ts.kind != from->ts.kind)
1978     {
1979       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1980                  "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1981                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1982                  &to->where, from->ts.kind, to->ts.kind);
1983       return FAILURE;
1984     }
1985
1986   return SUCCESS;
1987 }
1988
1989
1990 try
1991 gfc_check_nearest (gfc_expr *x, gfc_expr *s)
1992 {
1993   if (type_check (x, 0, BT_REAL) == FAILURE)
1994     return FAILURE;
1995
1996   if (type_check (s, 1, BT_REAL) == FAILURE)
1997     return FAILURE;
1998
1999   return SUCCESS;
2000 }
2001
2002
2003 try
2004 gfc_check_new_line (gfc_expr *a)
2005 {
2006   if (type_check (a, 0, BT_CHARACTER) == FAILURE)
2007     return FAILURE;
2008
2009   return SUCCESS;
2010 }
2011
2012
2013 try
2014 gfc_check_null (gfc_expr *mold)
2015 {
2016   symbol_attribute attr;
2017
2018   if (mold == NULL)
2019     return SUCCESS;
2020
2021   if (variable_check (mold, 0) == FAILURE)
2022     return FAILURE;
2023
2024   attr = gfc_variable_attr (mold, NULL);
2025
2026   if (!attr.pointer)
2027     {
2028       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
2029                  gfc_current_intrinsic_arg[0],
2030                  gfc_current_intrinsic, &mold->where);
2031       return FAILURE;
2032     }
2033
2034   return SUCCESS;
2035 }
2036
2037
2038 try
2039 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
2040 {
2041   char buffer[80];
2042
2043   if (array_check (array, 0) == FAILURE)
2044     return FAILURE;
2045
2046   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2047     return FAILURE;
2048
2049   snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
2050             gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
2051             gfc_current_intrinsic);
2052   if (gfc_check_conformance (buffer, array, mask) == FAILURE)
2053     return FAILURE;
2054
2055   if (vector != NULL)
2056     {
2057       if (same_type_check (array, 0, vector, 2) == FAILURE)
2058         return FAILURE;
2059
2060       if (rank_check (vector, 2, 1) == FAILURE)
2061         return FAILURE;
2062
2063       /* TODO: More constraints here.  */
2064     }
2065
2066   return SUCCESS;
2067 }
2068
2069
2070 try
2071 gfc_check_precision (gfc_expr *x)
2072 {
2073   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
2074     {
2075       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
2076                  "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
2077                  gfc_current_intrinsic, &x->where);
2078       return FAILURE;
2079     }
2080
2081   return SUCCESS;
2082 }
2083
2084
2085 try
2086 gfc_check_present (gfc_expr *a)
2087 {
2088   gfc_symbol *sym;
2089
2090   if (variable_check (a, 0) == FAILURE)
2091     return FAILURE;
2092
2093   sym = a->symtree->n.sym;
2094   if (!sym->attr.dummy)
2095     {
2096       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
2097                  "dummy variable", gfc_current_intrinsic_arg[0],
2098                  gfc_current_intrinsic, &a->where);
2099       return FAILURE;
2100     }
2101
2102   if (!sym->attr.optional)
2103     {
2104       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
2105                  "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
2106                  gfc_current_intrinsic, &a->where);
2107       return FAILURE;
2108     }
2109
2110   /* 13.14.82  PRESENT(A)
2111      ......
2112      Argument.  A shall be the name of an optional dummy argument that is
2113      accessible in the subprogram in which the PRESENT function reference
2114      appears...  */
2115
2116   if (a->ref != NULL
2117       && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
2118            && a->ref->u.ar.type == AR_FULL))
2119     {
2120       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
2121                  "subobject of '%s'", gfc_current_intrinsic_arg[0],
2122                  gfc_current_intrinsic, &a->where, sym->name);
2123       return FAILURE;
2124     }
2125
2126   return SUCCESS;
2127 }
2128
2129
2130 try
2131 gfc_check_radix (gfc_expr *x)
2132 {
2133   if (int_or_real_check (x, 0) == FAILURE)
2134     return FAILURE;
2135
2136   return SUCCESS;
2137 }
2138
2139
2140 try
2141 gfc_check_range (gfc_expr *x)
2142 {
2143   if (numeric_check (x, 0) == FAILURE)
2144     return FAILURE;
2145
2146   return SUCCESS;
2147 }
2148
2149
2150 /* real, float, sngl.  */
2151 try
2152 gfc_check_real (gfc_expr *a, gfc_expr *kind)
2153 {
2154   if (numeric_check (a, 0) == FAILURE)
2155     return FAILURE;
2156
2157   if (kind_check (kind, 1, BT_REAL) == FAILURE)
2158     return FAILURE;
2159
2160   return SUCCESS;
2161 }
2162
2163
2164 try
2165 gfc_check_rename (gfc_expr *path1, gfc_expr *path2)
2166 {
2167   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2168     return FAILURE;
2169
2170   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2171     return FAILURE;
2172
2173   return SUCCESS;
2174 }
2175
2176
2177 try
2178 gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
2179 {
2180   if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
2181     return FAILURE;
2182
2183   if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
2184     return FAILURE;
2185
2186   if (status == NULL)
2187     return SUCCESS;
2188
2189   if (type_check (status, 2, BT_INTEGER) == FAILURE)
2190     return FAILURE;
2191
2192   if (scalar_check (status, 2) == FAILURE)
2193     return FAILURE;
2194
2195   return SUCCESS;
2196 }
2197
2198
2199 try
2200 gfc_check_repeat (gfc_expr *x, gfc_expr *y)
2201 {
2202   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2203     return FAILURE;
2204
2205   if (scalar_check (x, 0) == FAILURE)
2206     return FAILURE;
2207
2208   if (type_check (y, 0, BT_INTEGER) == FAILURE)
2209     return FAILURE;
2210
2211   if (scalar_check (y, 1) == FAILURE)
2212     return FAILURE;
2213
2214   return SUCCESS;
2215 }
2216
2217
2218 try
2219 gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
2220                    gfc_expr *pad, gfc_expr *order)
2221 {
2222   mpz_t size;
2223   mpz_t nelems;
2224   int m;
2225
2226   if (array_check (source, 0) == FAILURE)
2227     return FAILURE;
2228
2229   if (rank_check (shape, 1, 1) == FAILURE)
2230     return FAILURE;
2231
2232   if (type_check (shape, 1, BT_INTEGER) == FAILURE)
2233     return FAILURE;
2234
2235   if (gfc_array_size (shape, &size) != SUCCESS)
2236     {
2237       gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
2238                  "array of constant size", &shape->where);
2239       return FAILURE;
2240     }
2241
2242   m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
2243   mpz_clear (size);
2244
2245   if (m > 0)
2246     {
2247       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
2248                  "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
2249       return FAILURE;
2250     }
2251
2252   if (pad != NULL)
2253     {
2254       if (same_type_check (source, 0, pad, 2) == FAILURE)
2255         return FAILURE;
2256       if (array_check (pad, 2) == FAILURE)
2257         return FAILURE;
2258     }
2259
2260   if (order != NULL && array_check (order, 3) == FAILURE)
2261     return FAILURE;
2262
2263   if (pad == NULL && shape->expr_type == EXPR_ARRAY
2264       && gfc_is_constant_expr (shape)
2265       && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as
2266            && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE))
2267     {
2268       /* Check the match in size between source and destination.  */
2269       if (gfc_array_size (source, &nelems) == SUCCESS)
2270         {
2271           gfc_constructor *c;
2272           bool test;
2273
2274           c = shape->value.constructor;
2275           mpz_init_set_ui (size, 1);
2276           for (; c; c = c->next)
2277             mpz_mul (size, size, c->expr->value.integer);
2278
2279           test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
2280           mpz_clear (nelems);
2281           mpz_clear (size);
2282
2283           if (test)
2284             {
2285               gfc_error ("Without padding, there are not enough elements "
2286                          "in the intrinsic RESHAPE source at %L to match "
2287                          "the shape", &source->where);
2288               return FAILURE;
2289             }
2290         }
2291     }
2292
2293   return SUCCESS;
2294 }
2295
2296
2297 try
2298 gfc_check_scale (gfc_expr *x, gfc_expr *i)
2299 {
2300   if (type_check (x, 0, BT_REAL) == FAILURE)
2301     return FAILURE;
2302
2303   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2304     return FAILURE;
2305
2306   return SUCCESS;
2307 }
2308
2309
2310 try
2311 gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2312 {
2313   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2314     return FAILURE;
2315
2316   if (type_check (y, 1, BT_CHARACTER) == FAILURE)
2317     return FAILURE;
2318
2319   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2320     return FAILURE;
2321
2322   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2323     return FAILURE;
2324   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2325                               "with KIND argument at %L",
2326                               gfc_current_intrinsic, &kind->where) == FAILURE)
2327     return FAILURE;
2328
2329   if (same_type_check (x, 0, y, 1) == FAILURE)
2330     return FAILURE;
2331
2332   return SUCCESS;
2333 }
2334
2335
2336 try
2337 gfc_check_secnds (gfc_expr *r)
2338 {
2339   if (type_check (r, 0, BT_REAL) == FAILURE)
2340     return FAILURE;
2341
2342   if (kind_value_check (r, 0, 4) == FAILURE)
2343     return FAILURE;
2344
2345   if (scalar_check (r, 0) == FAILURE)
2346     return FAILURE;
2347
2348   return SUCCESS;
2349 }
2350
2351
2352 try
2353 gfc_check_selected_int_kind (gfc_expr *r)
2354 {
2355   if (type_check (r, 0, BT_INTEGER) == FAILURE)
2356     return FAILURE;
2357
2358   if (scalar_check (r, 0) == FAILURE)
2359     return FAILURE;
2360
2361   return SUCCESS;
2362 }
2363
2364
2365 try
2366 gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
2367 {
2368   if (p == NULL && r == NULL)
2369     {
2370       gfc_error ("Missing arguments to %s intrinsic at %L",
2371                  gfc_current_intrinsic, gfc_current_intrinsic_where);
2372
2373       return FAILURE;
2374     }
2375
2376   if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
2377     return FAILURE;
2378
2379   if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
2380     return FAILURE;
2381
2382   return SUCCESS;
2383 }
2384
2385
2386 try
2387 gfc_check_set_exponent (gfc_expr *x, gfc_expr *i)
2388 {
2389   if (type_check (x, 0, BT_REAL) == FAILURE)
2390     return FAILURE;
2391
2392   if (type_check (i, 1, BT_INTEGER) == FAILURE)
2393     return FAILURE;
2394
2395   return SUCCESS;
2396 }
2397
2398
2399 try
2400 gfc_check_shape (gfc_expr *source)
2401 {
2402   gfc_array_ref *ar;
2403
2404   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
2405     return SUCCESS;
2406
2407   ar = gfc_find_array_ref (source);
2408
2409   if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
2410     {
2411       gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
2412                  "an assumed size array", &source->where);
2413       return FAILURE;
2414     }
2415
2416   return SUCCESS;
2417 }
2418
2419
2420 try
2421 gfc_check_sign (gfc_expr *a, gfc_expr *b)
2422 {
2423   if (int_or_real_check (a, 0) == FAILURE)
2424     return FAILURE;
2425
2426   if (same_type_check (a, 0, b, 1) == FAILURE)
2427     return FAILURE;
2428
2429   return SUCCESS;
2430 }
2431
2432
2433 try
2434 gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2435 {
2436   if (array_check (array, 0) == FAILURE)
2437     return FAILURE;
2438
2439   if (dim != NULL)
2440     {
2441       if (dim_check (dim, 1, true) == FAILURE)
2442         return FAILURE;
2443
2444       if (dim_rank_check (dim, array, 0) == FAILURE)
2445         return FAILURE;
2446     }
2447
2448   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2449     return FAILURE;
2450   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2451                               "with KIND argument at %L",
2452                               gfc_current_intrinsic, &kind->where) == FAILURE)
2453     return FAILURE;
2454
2455
2456   return SUCCESS;
2457 }
2458
2459
2460 try
2461 gfc_check_sizeof (gfc_expr *arg __attribute__((unused)))
2462 {
2463   return SUCCESS;
2464 }
2465
2466
2467 try
2468 gfc_check_sleep_sub (gfc_expr *seconds)
2469 {
2470   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
2471     return FAILURE;
2472
2473   if (scalar_check (seconds, 0) == FAILURE)
2474     return FAILURE;
2475
2476   return SUCCESS;
2477 }
2478
2479
2480 try
2481 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
2482 {
2483   if (source->rank >= GFC_MAX_DIMENSIONS)
2484     {
2485       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
2486                  "than rank %d", gfc_current_intrinsic_arg[0],
2487                  gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
2488
2489       return FAILURE;
2490     }
2491
2492   if (dim == NULL)
2493     return FAILURE;
2494
2495   if (dim_check (dim, 1, false) == FAILURE)
2496     return FAILURE;
2497
2498   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
2499     return FAILURE;
2500
2501   if (scalar_check (ncopies, 2) == FAILURE)
2502     return FAILURE;
2503
2504   return SUCCESS;
2505 }
2506
2507
2508 /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
2509    functions).  */
2510
2511 try
2512 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
2513 {
2514   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2515     return FAILURE;
2516
2517   if (scalar_check (unit, 0) == FAILURE)
2518     return FAILURE;
2519
2520   if (type_check (c, 1, BT_CHARACTER) == FAILURE)
2521     return FAILURE;
2522
2523   if (status == NULL)
2524     return SUCCESS;
2525
2526   if (type_check (status, 2, BT_INTEGER) == FAILURE
2527       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
2528       || scalar_check (status, 2) == FAILURE)
2529     return FAILURE;
2530
2531   return SUCCESS;
2532 }
2533
2534
2535 try
2536 gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c)
2537 {
2538   return gfc_check_fgetputc_sub (unit, c, NULL);
2539 }
2540
2541
2542 try
2543 gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
2544 {
2545   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
2546     return FAILURE;
2547
2548   if (status == NULL)
2549     return SUCCESS;
2550
2551   if (type_check (status, 1, BT_INTEGER) == FAILURE
2552       || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
2553       || scalar_check (status, 1) == FAILURE)
2554     return FAILURE;
2555
2556   return SUCCESS;
2557 }
2558
2559
2560 try
2561 gfc_check_fgetput (gfc_expr *c)
2562 {
2563   return gfc_check_fgetput_sub (c, NULL);
2564 }
2565
2566
2567 try
2568 gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status)
2569 {
2570   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2571     return FAILURE;
2572
2573   if (scalar_check (unit, 0) == FAILURE)
2574     return FAILURE;
2575
2576   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2577     return FAILURE;
2578
2579   if (scalar_check (offset, 1) == FAILURE)
2580     return FAILURE;
2581
2582   if (type_check (whence, 2, BT_INTEGER) == FAILURE)
2583     return FAILURE;
2584
2585   if (scalar_check (whence, 2) == FAILURE)
2586     return FAILURE;
2587
2588   if (status == NULL)
2589     return SUCCESS;
2590
2591   if (type_check (status, 3, BT_INTEGER) == FAILURE)
2592     return FAILURE;
2593
2594   if (kind_value_check (status, 3, 4) == FAILURE)
2595     return FAILURE;
2596
2597   if (scalar_check (status, 3) == FAILURE)
2598     return FAILURE;
2599
2600   return SUCCESS;
2601 }
2602
2603
2604
2605 try
2606 gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
2607 {
2608   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2609     return FAILURE;
2610
2611   if (scalar_check (unit, 0) == FAILURE)
2612     return FAILURE;
2613
2614   if (type_check (array, 1, BT_INTEGER) == FAILURE
2615       || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
2616     return FAILURE;
2617
2618   if (array_check (array, 1) == FAILURE)
2619     return FAILURE;
2620
2621   return SUCCESS;
2622 }
2623
2624
2625 try
2626 gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
2627 {
2628   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2629     return FAILURE;
2630
2631   if (scalar_check (unit, 0) == FAILURE)
2632     return FAILURE;
2633
2634   if (type_check (array, 1, BT_INTEGER) == FAILURE
2635       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2636     return FAILURE;
2637
2638   if (array_check (array, 1) == FAILURE)
2639     return FAILURE;
2640
2641   if (status == NULL)
2642     return SUCCESS;
2643
2644   if (type_check (status, 2, BT_INTEGER) == FAILURE
2645       || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
2646     return FAILURE;
2647
2648   if (scalar_check (status, 2) == FAILURE)
2649     return FAILURE;
2650
2651   return SUCCESS;
2652 }
2653
2654
2655 try
2656 gfc_check_ftell (gfc_expr *unit)
2657 {
2658   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2659     return FAILURE;
2660
2661   if (scalar_check (unit, 0) == FAILURE)
2662     return FAILURE;
2663
2664   return SUCCESS;
2665 }
2666
2667
2668 try
2669 gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
2670 {
2671   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2672     return FAILURE;
2673
2674   if (scalar_check (unit, 0) == FAILURE)
2675     return FAILURE;
2676
2677   if (type_check (offset, 1, BT_INTEGER) == FAILURE)
2678     return FAILURE;
2679
2680   if (scalar_check (offset, 1) == FAILURE)
2681     return FAILURE;
2682
2683   return SUCCESS;
2684 }
2685
2686
2687 try
2688 gfc_check_stat (gfc_expr *name, gfc_expr *array)
2689 {
2690   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2691     return FAILURE;
2692
2693   if (type_check (array, 1, BT_INTEGER) == FAILURE
2694       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2695     return FAILURE;
2696
2697   if (array_check (array, 1) == FAILURE)
2698     return FAILURE;
2699
2700   return SUCCESS;
2701 }
2702
2703
2704 try
2705 gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
2706 {
2707   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
2708     return FAILURE;
2709
2710   if (type_check (array, 1, BT_INTEGER) == FAILURE
2711       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2712     return FAILURE;
2713
2714   if (array_check (array, 1) == FAILURE)
2715     return FAILURE;
2716
2717   if (status == NULL)
2718     return SUCCESS;
2719
2720   if (type_check (status, 2, BT_INTEGER) == FAILURE
2721       || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
2722     return FAILURE;
2723
2724   if (scalar_check (status, 2) == FAILURE)
2725     return FAILURE;
2726
2727   return SUCCESS;
2728 }
2729
2730
2731 try
2732 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
2733                     gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
2734 {
2735   if (mold->ts.type == BT_HOLLERITH)
2736     {
2737       gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
2738                  &mold->where, gfc_basic_typename (BT_HOLLERITH));
2739       return FAILURE;
2740     }
2741
2742   if (size != NULL)
2743     {
2744       if (type_check (size, 2, BT_INTEGER) == FAILURE)
2745         return FAILURE;
2746
2747       if (scalar_check (size, 2) == FAILURE)
2748         return FAILURE;
2749
2750       if (nonoptional_check (size, 2) == FAILURE)
2751         return FAILURE;
2752     }
2753
2754   return SUCCESS;
2755 }
2756
2757
2758 try
2759 gfc_check_transpose (gfc_expr *matrix)
2760 {
2761   if (rank_check (matrix, 0, 2) == FAILURE)
2762     return FAILURE;
2763
2764   return SUCCESS;
2765 }
2766
2767
2768 try
2769 gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2770 {
2771   if (array_check (array, 0) == FAILURE)
2772     return FAILURE;
2773
2774   if (dim != NULL)
2775     {
2776       if (dim_check (dim, 1, false) == FAILURE)
2777         return FAILURE;
2778
2779       if (dim_rank_check (dim, array, 0) == FAILURE)
2780         return FAILURE;
2781     }
2782
2783   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
2784     return FAILURE;
2785   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2786                               "with KIND argument at %L",
2787                               gfc_current_intrinsic, &kind->where) == FAILURE)
2788     return FAILURE;
2789
2790   return SUCCESS;
2791 }
2792
2793
2794 try
2795 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
2796 {
2797   if (rank_check (vector, 0, 1) == FAILURE)
2798     return FAILURE;
2799
2800   if (array_check (mask, 1) == FAILURE)
2801     return FAILURE;
2802
2803   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
2804     return FAILURE;
2805
2806   if (same_type_check (vector, 0, field, 2) == FAILURE)
2807     return FAILURE;
2808
2809   return SUCCESS;
2810 }
2811
2812
2813 try
2814 gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
2815 {
2816   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2817     return FAILURE;
2818
2819   if (same_type_check (x, 0, y, 1) == FAILURE)
2820     return FAILURE;
2821
2822   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
2823     return FAILURE;
2824
2825   if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
2826     return FAILURE;
2827   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
2828                               "with KIND argument at %L",
2829                               gfc_current_intrinsic, &kind->where) == FAILURE)
2830     return FAILURE;
2831
2832   return SUCCESS;
2833 }
2834
2835
2836 try
2837 gfc_check_trim (gfc_expr *x)
2838 {
2839   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
2840     return FAILURE;
2841
2842   if (scalar_check (x, 0) == FAILURE)
2843     return FAILURE;
2844
2845    return SUCCESS;
2846 }
2847
2848
2849 try
2850 gfc_check_ttynam (gfc_expr *unit)
2851 {
2852   if (scalar_check (unit, 0) == FAILURE)
2853     return FAILURE;
2854
2855   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
2856     return FAILURE;
2857
2858   return SUCCESS;
2859 }
2860
2861
2862 /* Common check function for the half a dozen intrinsics that have a
2863    single real argument.  */
2864
2865 try
2866 gfc_check_x (gfc_expr *x)
2867 {
2868   if (type_check (x, 0, BT_REAL) == FAILURE)
2869     return FAILURE;
2870
2871   return SUCCESS;
2872 }
2873
2874
2875 /************* Check functions for intrinsic subroutines *************/
2876
2877 try
2878 gfc_check_cpu_time (gfc_expr *time)
2879 {
2880   if (scalar_check (time, 0) == FAILURE)
2881     return FAILURE;
2882
2883   if (type_check (time, 0, BT_REAL) == FAILURE)
2884     return FAILURE;
2885
2886   if (variable_check (time, 0) == FAILURE)
2887     return FAILURE;
2888
2889   return SUCCESS;
2890 }
2891
2892
2893 try
2894 gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
2895                          gfc_expr *zone, gfc_expr *values)
2896 {
2897   if (date != NULL)
2898     {
2899       if (type_check (date, 0, BT_CHARACTER) == FAILURE)
2900         return FAILURE;
2901       if (scalar_check (date, 0) == FAILURE)
2902         return FAILURE;
2903       if (variable_check (date, 0) == FAILURE)
2904         return FAILURE;
2905     }
2906
2907   if (time != NULL)
2908     {
2909       if (type_check (time, 1, BT_CHARACTER) == FAILURE)
2910         return FAILURE;
2911       if (scalar_check (time, 1) == FAILURE)
2912         return FAILURE;
2913       if (variable_check (time, 1) == FAILURE)
2914         return FAILURE;
2915     }
2916
2917   if (zone != NULL)
2918     {
2919       if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
2920         return FAILURE;
2921       if (scalar_check (zone, 2) == FAILURE)
2922         return FAILURE;
2923       if (variable_check (zone, 2) == FAILURE)
2924         return FAILURE;
2925     }
2926
2927   if (values != NULL)
2928     {
2929       if (type_check (values, 3, BT_INTEGER) == FAILURE)
2930         return FAILURE;
2931       if (array_check (values, 3) == FAILURE)
2932         return FAILURE;
2933       if (rank_check (values, 3, 1) == FAILURE)
2934         return FAILURE;
2935       if (variable_check (values, 3) == FAILURE)
2936         return FAILURE;
2937     }
2938
2939   return SUCCESS;
2940 }
2941
2942
2943 try
2944 gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
2945                   gfc_expr *to, gfc_expr *topos)
2946 {
2947   if (type_check (from, 0, BT_INTEGER) == FAILURE)
2948     return FAILURE;
2949
2950   if (type_check (frompos, 1, BT_INTEGER) == FAILURE)
2951     return FAILURE;
2952
2953   if (type_check (len, 2, BT_INTEGER) == FAILURE)
2954     return FAILURE;
2955
2956   if (same_type_check (from, 0, to, 3) == FAILURE)
2957     return FAILURE;
2958
2959   if (variable_check (to, 3) == FAILURE)
2960     return FAILURE;
2961
2962   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
2963     return FAILURE;
2964
2965   return SUCCESS;
2966 }
2967
2968
2969 try
2970 gfc_check_random_number (gfc_expr *harvest)
2971 {
2972   if (type_check (harvest, 0, BT_REAL) == FAILURE)
2973     return FAILURE;
2974
2975   if (variable_check (harvest, 0) == FAILURE)
2976     return FAILURE;
2977
2978   return SUCCESS;
2979 }
2980
2981
2982 try
2983 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
2984 {
2985   unsigned int nargs = 0;
2986   locus *where = NULL;
2987
2988   if (size != NULL)
2989     {
2990       if (size->expr_type != EXPR_VARIABLE
2991           || !size->symtree->n.sym->attr.optional)
2992         nargs++;
2993
2994       if (scalar_check (size, 0) == FAILURE)
2995         return FAILURE;
2996
2997       if (type_check (size, 0, BT_INTEGER) == FAILURE)
2998         return FAILURE;
2999
3000       if (variable_check (size, 0) == FAILURE)
3001         return FAILURE;
3002
3003       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
3004         return FAILURE;
3005     }
3006
3007   if (put != NULL)
3008     {
3009       if (put->expr_type != EXPR_VARIABLE
3010           || !put->symtree->n.sym->attr.optional)
3011         {
3012           nargs++;
3013           where = &put->where;
3014         }
3015
3016       if (array_check (put, 1) == FAILURE)
3017         return FAILURE;
3018
3019       if (rank_check (put, 1, 1) == FAILURE)
3020         return FAILURE;
3021
3022       if (type_check (put, 1, BT_INTEGER) == FAILURE)
3023         return FAILURE;
3024
3025       if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
3026         return FAILURE;
3027     }
3028
3029   if (get != NULL)
3030     {
3031       if (get->expr_type != EXPR_VARIABLE
3032           || !get->symtree->n.sym->attr.optional)
3033         {
3034           nargs++;
3035           where = &get->where;
3036         }
3037
3038       if (array_check (get, 2) == FAILURE)
3039         return FAILURE;
3040
3041       if (rank_check (get, 2, 1) == FAILURE)
3042         return FAILURE;
3043
3044       if (type_check (get, 2, BT_INTEGER) == FAILURE)
3045         return FAILURE;
3046
3047       if (variable_check (get, 2) == FAILURE)
3048         return FAILURE;
3049
3050       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
3051         return FAILURE;
3052     }
3053
3054   /* RANDOM_SEED may not have more than one non-optional argument.  */
3055   if (nargs > 1)
3056     gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
3057
3058   return SUCCESS;
3059 }
3060
3061
3062 try
3063 gfc_check_second_sub (gfc_expr *time)
3064 {
3065   if (scalar_check (time, 0) == FAILURE)
3066     return FAILURE;
3067
3068   if (type_check (time, 0, BT_REAL) == FAILURE)
3069     return FAILURE;
3070
3071   if (kind_value_check(time, 0, 4) == FAILURE)
3072     return FAILURE;
3073
3074   return SUCCESS;
3075 }
3076
3077
3078 /* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
3079    count, count_rate, and count_max are all optional arguments */
3080
3081 try
3082 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
3083                         gfc_expr *count_max)
3084 {
3085   if (count != NULL)
3086     {
3087       if (scalar_check (count, 0) == FAILURE)
3088         return FAILURE;
3089
3090       if (type_check (count, 0, BT_INTEGER) == FAILURE)
3091         return FAILURE;
3092
3093       if (variable_check (count, 0) == FAILURE)
3094         return FAILURE;
3095     }
3096
3097   if (count_rate != NULL)
3098     {
3099       if (scalar_check (count_rate, 1) == FAILURE)
3100         return FAILURE;
3101
3102       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
3103         return FAILURE;
3104
3105       if (variable_check (count_rate, 1) == FAILURE)
3106         return FAILURE;
3107
3108       if (count != NULL
3109           && same_type_check (count, 0, count_rate, 1) == FAILURE)
3110         return FAILURE;
3111
3112     }
3113
3114   if (count_max != NULL)
3115     {
3116       if (scalar_check (count_max, 2) == FAILURE)
3117         return FAILURE;
3118
3119       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
3120         return FAILURE;
3121
3122       if (variable_check (count_max, 2) == FAILURE)
3123         return FAILURE;
3124
3125       if (count != NULL
3126           && same_type_check (count, 0, count_max, 2) == FAILURE)
3127         return FAILURE;
3128
3129       if (count_rate != NULL
3130           && same_type_check (count_rate, 1, count_max, 2) == FAILURE)
3131         return FAILURE;
3132     }
3133
3134   return SUCCESS;
3135 }
3136
3137
3138 try
3139 gfc_check_irand (gfc_expr *x)
3140 {
3141   if (x == NULL)
3142     return SUCCESS;
3143
3144   if (scalar_check (x, 0) == FAILURE)
3145     return FAILURE;
3146
3147   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3148     return FAILURE;
3149
3150   if (kind_value_check(x, 0, 4) == FAILURE)
3151     return FAILURE;
3152
3153   return SUCCESS;
3154 }
3155
3156
3157 try
3158 gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
3159 {
3160   if (scalar_check (seconds, 0) == FAILURE)
3161     return FAILURE;
3162
3163   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
3164     return FAILURE;
3165
3166   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3167     {
3168       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3169                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3170                  gfc_current_intrinsic, &handler->where);
3171       return FAILURE;
3172     }
3173
3174   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3175     return FAILURE;
3176
3177   if (status == NULL)
3178     return SUCCESS;
3179
3180   if (scalar_check (status, 2) == FAILURE)
3181     return FAILURE;
3182
3183   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3184     return FAILURE;
3185
3186   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
3187     return FAILURE;
3188
3189   return SUCCESS;
3190 }
3191
3192
3193 try
3194 gfc_check_rand (gfc_expr *x)
3195 {
3196   if (x == NULL)
3197     return SUCCESS;
3198
3199   if (scalar_check (x, 0) == FAILURE)
3200     return FAILURE;
3201
3202   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3203     return FAILURE;
3204
3205   if (kind_value_check(x, 0, 4) == FAILURE)
3206     return FAILURE;
3207
3208   return SUCCESS;
3209 }
3210
3211
3212 try
3213 gfc_check_srand (gfc_expr *x)
3214 {
3215   if (scalar_check (x, 0) == FAILURE)
3216     return FAILURE;
3217
3218   if (type_check (x, 0, BT_INTEGER) == FAILURE)
3219     return FAILURE;
3220
3221   if (kind_value_check(x, 0, 4) == FAILURE)
3222     return FAILURE;
3223
3224   return SUCCESS;
3225 }
3226
3227
3228 try
3229 gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result)
3230 {
3231   if (scalar_check (time, 0) == FAILURE)
3232     return FAILURE;
3233
3234   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3235     return FAILURE;
3236
3237   if (type_check (result, 1, BT_CHARACTER) == FAILURE)
3238     return FAILURE;
3239
3240   return SUCCESS;
3241 }
3242
3243
3244 try
3245 gfc_check_dtime_etime (gfc_expr *x)
3246 {
3247   if (array_check (x, 0) == FAILURE)
3248     return FAILURE;
3249
3250   if (rank_check (x, 0, 1) == FAILURE)
3251     return FAILURE;
3252
3253   if (variable_check (x, 0) == FAILURE)
3254     return FAILURE;
3255
3256   if (type_check (x, 0, BT_REAL) == FAILURE)
3257     return FAILURE;
3258
3259   if (kind_value_check(x, 0, 4) == FAILURE)
3260     return FAILURE;
3261
3262   return SUCCESS;
3263 }
3264
3265
3266 try
3267 gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
3268 {
3269   if (array_check (values, 0) == FAILURE)
3270     return FAILURE;
3271
3272   if (rank_check (values, 0, 1) == FAILURE)
3273     return FAILURE;
3274
3275   if (variable_check (values, 0) == FAILURE)
3276     return FAILURE;
3277
3278   if (type_check (values, 0, BT_REAL) == FAILURE)
3279     return FAILURE;
3280
3281   if (kind_value_check(values, 0, 4) == FAILURE)
3282     return FAILURE;
3283
3284   if (scalar_check (time, 1) == FAILURE)
3285     return FAILURE;
3286
3287   if (type_check (time, 1, BT_REAL) == FAILURE)
3288     return FAILURE;
3289
3290   if (kind_value_check(time, 1, 4) == FAILURE)
3291     return FAILURE;
3292
3293   return SUCCESS;
3294 }
3295
3296
3297 try
3298 gfc_check_fdate_sub (gfc_expr *date)
3299 {
3300   if (type_check (date, 0, BT_CHARACTER) == FAILURE)
3301     return FAILURE;
3302
3303   return SUCCESS;
3304 }
3305
3306
3307 try
3308 gfc_check_gerror (gfc_expr *msg)
3309 {
3310   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3311     return FAILURE;
3312
3313   return SUCCESS;
3314 }
3315
3316
3317 try
3318 gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
3319 {
3320   if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
3321     return FAILURE;
3322
3323   if (status == NULL)
3324     return SUCCESS;
3325
3326   if (scalar_check (status, 1) == FAILURE)
3327     return FAILURE;
3328
3329   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3330     return FAILURE;
3331
3332   return SUCCESS;
3333 }
3334
3335
3336 try
3337 gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
3338 {
3339   if (type_check (pos, 0, BT_INTEGER) == FAILURE)
3340     return FAILURE;
3341
3342   if (pos->ts.kind > gfc_default_integer_kind)
3343     {
3344       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
3345                  "not wider than the default kind (%d)",
3346                  gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
3347                  &pos->where, gfc_default_integer_kind);
3348       return FAILURE;
3349     }
3350
3351   if (type_check (value, 1, BT_CHARACTER) == FAILURE)
3352     return FAILURE;
3353
3354   return SUCCESS;
3355 }
3356
3357
3358 try
3359 gfc_check_getlog (gfc_expr *msg)
3360 {
3361   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
3362     return FAILURE;
3363
3364   return SUCCESS;
3365 }
3366
3367
3368 try
3369 gfc_check_exit (gfc_expr *status)
3370 {
3371   if (status == NULL)
3372     return SUCCESS;
3373
3374   if (type_check (status, 0, BT_INTEGER) == FAILURE)
3375     return FAILURE;
3376
3377   if (scalar_check (status, 0) == FAILURE)
3378     return FAILURE;
3379
3380   return SUCCESS;
3381 }
3382
3383
3384 try
3385 gfc_check_flush (gfc_expr *unit)
3386 {
3387   if (unit == NULL)
3388     return SUCCESS;
3389
3390   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3391     return FAILURE;
3392
3393   if (scalar_check (unit, 0) == FAILURE)
3394     return FAILURE;
3395
3396   return SUCCESS;
3397 }
3398
3399
3400 try
3401 gfc_check_free (gfc_expr *i)
3402 {
3403   if (type_check (i, 0, BT_INTEGER) == FAILURE)
3404     return FAILURE;
3405
3406   if (scalar_check (i, 0) == FAILURE)
3407     return FAILURE;
3408
3409   return SUCCESS;
3410 }
3411
3412
3413 try
3414 gfc_check_hostnm (gfc_expr *name)
3415 {
3416   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3417     return FAILURE;
3418
3419   return SUCCESS;
3420 }
3421
3422
3423 try
3424 gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status)
3425 {
3426   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3427     return FAILURE;
3428
3429   if (status == NULL)
3430     return SUCCESS;
3431
3432   if (scalar_check (status, 1) == FAILURE)
3433     return FAILURE;
3434
3435   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3436     return FAILURE;
3437
3438   return SUCCESS;
3439 }
3440
3441
3442 try
3443 gfc_check_itime_idate (gfc_expr *values)
3444 {
3445   if (array_check (values, 0) == FAILURE)
3446     return FAILURE;
3447
3448   if (rank_check (values, 0, 1) == FAILURE)
3449     return FAILURE;
3450
3451   if (variable_check (values, 0) == FAILURE)
3452     return FAILURE;
3453
3454   if (type_check (values, 0, BT_INTEGER) == FAILURE)
3455     return FAILURE;
3456
3457   if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
3458     return FAILURE;
3459
3460   return SUCCESS;
3461 }
3462
3463
3464 try
3465 gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
3466 {
3467   if (type_check (time, 0, BT_INTEGER) == FAILURE)
3468     return FAILURE;
3469
3470   if (kind_value_check(time, 0, gfc_default_integer_kind) == FAILURE)
3471     return FAILURE;
3472
3473   if (scalar_check (time, 0) == FAILURE)
3474     return FAILURE;
3475
3476   if (array_check (values, 1) == FAILURE)
3477     return FAILURE;
3478
3479   if (rank_check (values, 1, 1) == FAILURE)
3480     return FAILURE;
3481
3482   if (variable_check (values, 1) == FAILURE)
3483     return FAILURE;
3484
3485   if (type_check (values, 1, BT_INTEGER) == FAILURE)
3486     return FAILURE;
3487
3488   if (kind_value_check(values, 1, gfc_default_integer_kind) == FAILURE)
3489     return FAILURE;
3490
3491   return SUCCESS;
3492 }
3493
3494
3495 try
3496 gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name)
3497 {
3498   if (scalar_check (unit, 0) == FAILURE)
3499     return FAILURE;
3500
3501   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3502     return FAILURE;
3503
3504   if (type_check (name, 1, BT_CHARACTER) == FAILURE)
3505     return FAILURE;
3506
3507   return SUCCESS;
3508 }
3509
3510
3511 try
3512 gfc_check_isatty (gfc_expr *unit)
3513 {
3514   if (unit == NULL)
3515     return FAILURE;
3516
3517   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
3518     return FAILURE;
3519
3520   if (scalar_check (unit, 0) == FAILURE)
3521     return FAILURE;
3522
3523   return SUCCESS;
3524 }
3525
3526
3527 try
3528 gfc_check_isnan (gfc_expr *x)
3529 {
3530   if (type_check (x, 0, BT_REAL) == FAILURE)
3531     return FAILURE;
3532
3533   return SUCCESS;
3534 }
3535
3536
3537 try
3538 gfc_check_perror (gfc_expr *string)
3539 {
3540   if (type_check (string, 0, BT_CHARACTER) == FAILURE)
3541     return FAILURE;
3542
3543   return SUCCESS;
3544 }
3545
3546
3547 try
3548 gfc_check_umask (gfc_expr *mask)
3549 {
3550   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3551     return FAILURE;
3552
3553   if (scalar_check (mask, 0) == FAILURE)
3554     return FAILURE;
3555
3556   return SUCCESS;
3557 }
3558
3559
3560 try
3561 gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
3562 {
3563   if (type_check (mask, 0, BT_INTEGER) == FAILURE)
3564     return FAILURE;
3565
3566   if (scalar_check (mask, 0) == FAILURE)
3567     return FAILURE;
3568
3569   if (old == NULL)
3570     return SUCCESS;
3571
3572   if (scalar_check (old, 1) == FAILURE)
3573     return FAILURE;
3574
3575   if (type_check (old, 1, BT_INTEGER) == FAILURE)
3576     return FAILURE;
3577
3578   return SUCCESS;
3579 }
3580
3581
3582 try
3583 gfc_check_unlink (gfc_expr *name)
3584 {
3585   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3586     return FAILURE;
3587
3588   return SUCCESS;
3589 }
3590
3591
3592 try
3593 gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status)
3594 {
3595   if (type_check (name, 0, BT_CHARACTER) == FAILURE)
3596     return FAILURE;
3597
3598   if (status == NULL)
3599     return SUCCESS;
3600
3601   if (scalar_check (status, 1) == FAILURE)
3602     return FAILURE;
3603
3604   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3605     return FAILURE;
3606
3607   return SUCCESS;
3608 }
3609
3610
3611 try
3612 gfc_check_signal (gfc_expr *number, gfc_expr *handler)
3613 {
3614   if (scalar_check (number, 0) == FAILURE)
3615     return FAILURE;
3616
3617   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3618     return FAILURE;
3619
3620   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3621     {
3622       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3623                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3624                  gfc_current_intrinsic, &handler->where);
3625       return FAILURE;
3626     }
3627
3628   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3629     return FAILURE;
3630
3631   return SUCCESS;
3632 }
3633
3634
3635 try
3636 gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
3637 {
3638   if (scalar_check (number, 0) == FAILURE)
3639     return FAILURE;
3640
3641   if (type_check (number, 0, BT_INTEGER) == FAILURE)
3642     return FAILURE;
3643
3644   if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
3645     {
3646       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3647                  "or PROCEDURE", gfc_current_intrinsic_arg[1],
3648                  gfc_current_intrinsic, &handler->where);
3649       return FAILURE;
3650     }
3651
3652   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
3653     return FAILURE;
3654
3655   if (status == NULL)
3656     return SUCCESS;
3657
3658   if (type_check (status, 2, BT_INTEGER) == FAILURE)
3659     return FAILURE;
3660
3661   if (scalar_check (status, 2) == FAILURE)
3662     return FAILURE;
3663
3664   return SUCCESS;
3665 }
3666
3667
3668 try
3669 gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status)
3670 {
3671   if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
3672     return FAILURE;
3673
3674   if (scalar_check (status, 1) == FAILURE)
3675     return FAILURE;
3676
3677   if (type_check (status, 1, BT_INTEGER) == FAILURE)
3678     return FAILURE;
3679
3680   if (kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE)
3681     return FAILURE;
3682
3683   return SUCCESS;
3684 }
3685
3686
3687 /* This is used for the GNU intrinsics AND, OR and XOR.  */
3688 try
3689 gfc_check_and (gfc_expr *i, gfc_expr *j)
3690 {
3691   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
3692     {
3693       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3694                  "or LOGICAL", gfc_current_intrinsic_arg[0],
3695                  gfc_current_intrinsic, &i->where);
3696       return FAILURE;
3697     }
3698
3699   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
3700     {
3701       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
3702                  "or LOGICAL", gfc_current_intrinsic_arg[1],
3703                  gfc_current_intrinsic, &j->where);
3704       return FAILURE;
3705     }
3706
3707   if (i->ts.type != j->ts.type)
3708     {
3709       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
3710                  "have the same type", gfc_current_intrinsic_arg[0],
3711                  gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
3712                  &j->where);
3713       return FAILURE;
3714     }
3715
3716   if (scalar_check (i, 0) == FAILURE)
3717     return FAILURE;
3718
3719   if (scalar_check (j, 1) == FAILURE)
3720     return FAILURE;
3721
3722   return SUCCESS;
3723 }