gcc/fortran/iresolve.c

   1 /* Intrinsic function resolution.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   3    2009, 2010
   4    Free Software Foundation, Inc.
   5    Contributed by Andy Vaught & Katherine Holcomb
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23
  24 /* Assign name and types to intrinsic procedures.  For functions, the
  25    first argument to a resolution function is an expression pointer to
  26    the original function node and the rest are pointers to the
  27    arguments of the function call.  For subroutines, a pointer to the
  28    code node is passed.  The result type and library subroutine name
  29    are generally set according to the function arguments.  */
  30
  31 #include "config.h"
  32 #include "system.h"
  33 #include "coretypes.h"
  34 #include "tree.h"
  35 #include "gfortran.h"
  36 #include "intrinsic.h"
  37 #include "constructor.h"
  38
  39 /* Given printf-like arguments, return a stable version of the result string.
  40
  41    We already have a working, optimized string hashing table in the form of
  42    the identifier table.  Reusing this table is likely not to be wasted,
  43    since if the function name makes it to the gimple output of the frontend,
  44    we'll have to create the identifier anyway.  */
  45
  46 const char *
  47 gfc_get_string (const char *format, ...)
  48 {
  49   char temp_name[128];
  50   va_list ap;
  51   tree ident;
  52
  53   va_start (ap, format);
  54   vsnprintf (temp_name, sizeof (temp_name), format, ap);
  55   va_end (ap);
  56   temp_name[sizeof (temp_name) - 1] = 0;
  57
  58   ident = get_identifier (temp_name);
  59   return IDENTIFIER_POINTER (ident);
  60 }
  61
  62 /* MERGE and SPREAD need to have source charlen's present for passing
  63    to the result expression.  */
  64 static void
  65 check_charlen_present (gfc_expr *source)
  66 {
  67   if (source->ts.u.cl == NULL)
  68     source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
  69
  70   if (source->expr_type == EXPR_CONSTANT)
  71     {
  72       source->ts.u.cl->length
  73                 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
  74                                     source->value.character.length);
  75       source->rank = 0;
  76     }
  77   else if (source->expr_type == EXPR_ARRAY)
  78     {
  79       gfc_constructor *c = gfc_constructor_first (source->value.constructor);
  80       source->ts.u.cl->length
  81                 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
  82                                     c->expr->value.character.length);
  83     }
  84 }
  85
  86 /* Helper function for resolving the "mask" argument.  */
  87
  88 static void
  89 resolve_mask_arg (gfc_expr *mask)
  90 {
  91
  92   gfc_typespec ts;
  93   gfc_clear_ts (&ts);
  94
  95   if (mask->rank == 0)
  96     {
  97       /* For the scalar case, coerce the mask to kind=4 unconditionally
  98          (because this is the only kind we have a library function
  99          for).  */
 100
 101       if (mask->ts.kind != 4)
 102         {
 103           ts.type = BT_LOGICAL;
 104           ts.kind = 4;
 105           gfc_convert_type (mask, &ts, 2);
 106         }
 107     }
 108   else
 109     {
 110       /* In the library, we access the mask with a GFC_LOGICAL_1
 111          argument.  No need to waste memory if we are about to create
 112          a temporary array.  */
 113       if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
 114         {
 115           ts.type = BT_LOGICAL;
 116           ts.kind = 1;
 117           gfc_convert_type_warn (mask, &ts, 2, 0);
 118         }
 119     }
 120 }
 121
 122
 123 static void
 124 resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
 125                const char *name, bool coarray)
 126 {
 127   f->ts.type = BT_INTEGER;
 128   if (kind)
 129     f->ts.kind = mpz_get_si (kind->value.integer);
 130   else
 131     f->ts.kind = gfc_default_integer_kind;
 132
 133   if (dim == NULL)
 134     {
 135       f->rank = 1;
 136       f->shape = gfc_get_shape (1);
 137       mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
 138                                             : array->rank);
 139     }
 140
 141   f->value.function.name = xstrdup (name);
 142 }
 143
 144 /********************** Resolution functions **********************/
 145
 146
 147 void
 148 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
 149 {
 150   f->ts = a->ts;
 151   if (f->ts.type == BT_COMPLEX)
 152     f->ts.type = BT_REAL;
 153
 154   f->value.function.name
 155     = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 156 }
 157
 158
 159 void
 160 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 161                     gfc_expr *mode ATTRIBUTE_UNUSED)
 162 {
 163   f->ts.type = BT_INTEGER;
 164   f->ts.kind = gfc_c_int_kind;
 165   f->value.function.name = PREFIX ("access_func");
 166 }
 167
 168
 169 void
 170 gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
 171 {
 172   f->ts.type = BT_CHARACTER;
 173   f->ts.kind = string->ts.kind;
 174   f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
 175 }
 176
 177
 178 void
 179 gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
 180 {
 181   f->ts.type = BT_CHARACTER;
 182   f->ts.kind = string->ts.kind;
 183   f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
 184 }
 185
 186
 187 static void
 188 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
 189                         const char *name)
 190 {
 191   f->ts.type = BT_CHARACTER;
 192   f->ts.kind = (kind == NULL)
 193              ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
 194   f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 195   f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 196
 197   f->value.function.name = gfc_get_string (name, f->ts.kind,
 198                                            gfc_type_letter (x->ts.type),
 199                                            x->ts.kind);
 200 }
 201
 202
 203 void
 204 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
 205 {
 206   gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
 207 }
 208
 209
 210 void
 211 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
 212 {
 213   f->ts = x->ts;
 214   f->value.function.name
 215     = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 216 }
 217
 218
 219 void
 220 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
 221 {
 222   f->ts = x->ts;
 223   f->value.function.name
 224     = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
 225                       x->ts.kind);
 226 }
 227
 228
 229 void
 230 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
 231 {
 232   f->ts.type = BT_REAL;
 233   f->ts.kind = x->ts.kind;
 234   f->value.function.name
 235     = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
 236                       x->ts.kind);
 237 }
 238
 239
 240 void
 241 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 242 {
 243   f->ts.type = i->ts.type;
 244   f->ts.kind = gfc_kind_max (i, j);
 245
 246   if (i->ts.kind != j->ts.kind)
 247     {
 248       if (i->ts.kind == gfc_kind_max (i, j))
 249         gfc_convert_type (j, &i->ts, 2);
 250       else
 251         gfc_convert_type (i, &j->ts, 2);
 252     }
 253
 254   f->value.function.name
 255     = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
 256 }
 257
 258
 259 void
 260 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 261 {
 262   gfc_typespec ts;
 263   gfc_clear_ts (&ts);
 264
 265   f->ts.type = a->ts.type;
 266   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 267
 268   if (a->ts.kind != f->ts.kind)
 269     {
 270       ts.type = f->ts.type;
 271       ts.kind = f->ts.kind;
 272       gfc_convert_type (a, &ts, 2);
 273     }
 274   /* The resolved name is only used for specific intrinsics where
 275      the return kind is the same as the arg kind.  */
 276   f->value.function.name
 277     = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 278 }
 279
 280
 281 void
 282 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
 283 {
 284   gfc_resolve_aint (f, a, NULL);
 285 }
 286
 287
 288 void
 289 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
 290 {
 291   f->ts = mask->ts;
 292
 293   if (dim != NULL)
 294     {
 295       gfc_resolve_dim_arg (dim);
 296       f->rank = mask->rank - 1;
 297       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 298     }
 299
 300   f->value.function.name
 301     = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
 302                       mask->ts.kind);
 303 }
 304
 305
 306 void
 307 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 308 {
 309   gfc_typespec ts;
 310   gfc_clear_ts (&ts);
 311
 312   f->ts.type = a->ts.type;
 313   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 314
 315   if (a->ts.kind != f->ts.kind)
 316     {
 317       ts.type = f->ts.type;
 318       ts.kind = f->ts.kind;
 319       gfc_convert_type (a, &ts, 2);
 320     }
 321
 322   /* The resolved name is only used for specific intrinsics where
 323      the return kind is the same as the arg kind.  */
 324   f->value.function.name
 325     = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
 326                       a->ts.kind);
 327 }
 328
 329
 330 void
 331 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
 332 {
 333   gfc_resolve_anint (f, a, NULL);
 334 }
 335
 336
 337 void
 338 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
 339 {
 340   f->ts = mask->ts;
 341
 342   if (dim != NULL)
 343     {
 344       gfc_resolve_dim_arg (dim);
 345       f->rank = mask->rank - 1;
 346       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 347     }
 348
 349   f->value.function.name
 350     = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
 351                       mask->ts.kind);
 352 }
 353
 354
 355 void
 356 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
 357 {
 358   f->ts = x->ts;
 359   f->value.function.name
 360     = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 361 }
 362
 363 void
 364 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
 365 {
 366   f->ts = x->ts;
 367   f->value.function.name
 368     = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
 369                       x->ts.kind);
 370 }
 371
 372 void
 373 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
 374 {
 375   f->ts = x->ts;
 376   f->value.function.name
 377     = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 378 }
 379
 380 void
 381 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
 382 {
 383   f->ts = x->ts;
 384   f->value.function.name
 385     = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
 386                       x->ts.kind);
 387 }
 388
 389 void
 390 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
 391 {
 392   f->ts = x->ts;
 393   f->value.function.name
 394     = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
 395                       x->ts.kind);
 396 }
 397
 398
 399 /* Resolve the BESYN and BESJN intrinsics.  */
 400
 401 void
 402 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
 403 {
 404   gfc_typespec ts;
 405   gfc_clear_ts (&ts);
 406
 407   f->ts = x->ts;
 408   if (n->ts.kind != gfc_c_int_kind)
 409     {
 410       ts.type = BT_INTEGER;
 411       ts.kind = gfc_c_int_kind;
 412       gfc_convert_type (n, &ts, 2);
 413     }
 414   f->value.function.name = gfc_get_string ("<intrinsic>");
 415 }
 416
 417
 418 void
 419 gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
 420 {
 421   gfc_typespec ts;
 422   gfc_clear_ts (&ts);
 423
 424   f->ts = x->ts;
 425   f->rank = 1;
 426   if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
 427     {
 428       f->shape = gfc_get_shape (1);
 429       mpz_init (f->shape[0]);
 430       mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
 431       mpz_add_ui (f->shape[0], f->shape[0], 1);
 432     }
 433
 434   if (n1->ts.kind != gfc_c_int_kind)
 435     {
 436       ts.type = BT_INTEGER;
 437       ts.kind = gfc_c_int_kind;
 438       gfc_convert_type (n1, &ts, 2);
 439     }
 440
 441   if (n2->ts.kind != gfc_c_int_kind)
 442     {
 443       ts.type = BT_INTEGER;
 444       ts.kind = gfc_c_int_kind;
 445       gfc_convert_type (n2, &ts, 2);
 446     }
 447
 448   if (f->value.function.isym->id == GFC_ISYM_JN2)
 449     f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
 450                                              f->ts.kind);
 451   else
 452     f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
 453                                              f->ts.kind);
 454 }
 455
 456
 457 void
 458 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
 459 {
 460   f->ts.type = BT_LOGICAL;
 461   f->ts.kind = gfc_default_logical_kind;
 462   f->value.function.name
 463     = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
 464 }
 465
 466
 467 void
 468 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 469 {
 470   f->ts.type = BT_INTEGER;
 471   f->ts.kind = (kind == NULL)
 472              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
 473   f->value.function.name
 474     = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
 475                       gfc_type_letter (a->ts.type), a->ts.kind);
 476 }
 477
 478
 479 void
 480 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 481 {
 482   gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
 483 }
 484
 485
 486 void
 487 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
 488 {
 489   f->ts.type = BT_INTEGER;
 490   f->ts.kind = gfc_default_integer_kind;
 491   f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
 492 }
 493
 494
 495 void
 496 gfc_resolve_chdir_sub (gfc_code *c)
 497 {
 498   const char *name;
 499   int kind;
 500
 501   if (c->ext.actual->next->expr != NULL)
 502     kind = c->ext.actual->next->expr->ts.kind;
 503   else
 504     kind = gfc_default_integer_kind;
 505
 506   name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
 507   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 508 }
 509
 510
 511 void
 512 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 513                    gfc_expr *mode ATTRIBUTE_UNUSED)
 514 {
 515   f->ts.type = BT_INTEGER;
 516   f->ts.kind = gfc_c_int_kind;
 517   f->value.function.name = PREFIX ("chmod_func");
 518 }
 519
 520
 521 void
 522 gfc_resolve_chmod_sub (gfc_code *c)
 523 {
 524   const char *name;
 525   int kind;
 526
 527   if (c->ext.actual->next->next->expr != NULL)
 528     kind = c->ext.actual->next->next->expr->ts.kind;
 529   else
 530     kind = gfc_default_integer_kind;
 531
 532   name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
 533   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 534 }
 535
 536
 537 void
 538 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
 539 {
 540   f->ts.type = BT_COMPLEX;
 541   f->ts.kind = (kind == NULL)
 542              ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
 543
 544   if (y == NULL)
 545     f->value.function.name
 546       = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
 547                         gfc_type_letter (x->ts.type), x->ts.kind);
 548   else
 549     f->value.function.name
 550       = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 551                         gfc_type_letter (x->ts.type), x->ts.kind,
 552                         gfc_type_letter (y->ts.type), y->ts.kind);
 553 }
 554
 555
 556 void
 557 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
 558 {
 559   gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
 560                                                 gfc_default_double_kind));
 561 }
 562
 563
 564 void
 565 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
 566 {
 567   int kind;
 568
 569   if (x->ts.type == BT_INTEGER)
 570     {
 571       if (y->ts.type == BT_INTEGER)
 572         kind = gfc_default_real_kind;
 573       else
 574         kind = y->ts.kind;
 575     }
 576   else
 577     {
 578       if (y->ts.type == BT_REAL)
 579         kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
 580       else
 581         kind = x->ts.kind;
 582     }
 583
 584   f->ts.type = BT_COMPLEX;
 585   f->ts.kind = kind;
 586   f->value.function.name
 587     = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 588                       gfc_type_letter (x->ts.type), x->ts.kind,
 589                       gfc_type_letter (y->ts.type), y->ts.kind);
 590 }
 591
 592
 593 void
 594 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
 595 {
 596   f->ts = x->ts;
 597   f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
 598 }
 599
 600
 601 void
 602 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
 603 {
 604   f->ts = x->ts;
 605   f->value.function.name
 606     = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 607 }
 608
 609
 610 void
 611 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
 612 {
 613   f->ts = x->ts;
 614   f->value.function.name
 615     = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 616 }
 617
 618
 619 void
 620 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 621 {
 622   f->ts.type = BT_INTEGER;
 623   if (kind)
 624     f->ts.kind = mpz_get_si (kind->value.integer);
 625   else
 626     f->ts.kind = gfc_default_integer_kind;
 627
 628   if (dim != NULL)
 629     {
 630       f->rank = mask->rank - 1;
 631       gfc_resolve_dim_arg (dim);
 632       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 633     }
 634
 635   resolve_mask_arg (mask);
 636
 637   f->value.function.name
 638     = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
 639                       gfc_type_letter (mask->ts.type));
 640 }
 641
 642
 643 void
 644 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
 645                     gfc_expr *dim)
 646 {
 647   int n, m;
 648
 649   if (array->ts.type == BT_CHARACTER && array->ref)
 650     gfc_resolve_substring_charlen (array);
 651
 652   f->ts = array->ts;
 653   f->rank = array->rank;
 654   f->shape = gfc_copy_shape (array->shape, array->rank);
 655
 656   if (shift->rank > 0)
 657     n = 1;
 658   else
 659     n = 0;
 660
 661   /* If dim kind is greater than default integer we need to use the larger.  */
 662   m = gfc_default_integer_kind;
 663   if (dim != NULL)
 664     m = m < dim->ts.kind ? dim->ts.kind : m;
 665
 666   /* Convert shift to at least m, so we don't need
 667       kind=1 and kind=2 versions of the library functions.  */
 668   if (shift->ts.kind < m)
 669     {
 670       gfc_typespec ts;
 671       gfc_clear_ts (&ts);
 672       ts.type = BT_INTEGER;
 673       ts.kind = m;
 674       gfc_convert_type_warn (shift, &ts, 2, 0);
 675     }
 676
 677   if (dim != NULL)
 678     {
 679       if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
 680           && dim->symtree->n.sym->attr.optional)
 681         {
 682           /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
 683           dim->representation.length = shift->ts.kind;
 684         }
 685       else
 686         {
 687           gfc_resolve_dim_arg (dim);
 688           /* Convert dim to shift's kind to reduce variations.  */
 689           if (dim->ts.kind != shift->ts.kind)
 690             gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 691         }
 692     }
 693
 694   if (array->ts.type == BT_CHARACTER)
 695     {
 696       if (array->ts.kind == gfc_default_character_kind)
 697         f->value.function.name
 698           = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
 699       else
 700         f->value.function.name
 701           = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
 702                             array->ts.kind);
 703     }
 704   else
 705     f->value.function.name
 706         = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
 707 }
 708
 709
 710 void
 711 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
 712 {
 713   gfc_typespec ts;
 714   gfc_clear_ts (&ts);
 715
 716   f->ts.type = BT_CHARACTER;
 717   f->ts.kind = gfc_default_character_kind;
 718
 719   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
 720   if (time->ts.kind != 8)
 721     {
 722       ts.type = BT_INTEGER;
 723       ts.kind = 8;
 724       ts.u.derived = NULL;
 725       ts.u.cl = NULL;
 726       gfc_convert_type (time, &ts, 2);
 727     }
 728
 729   f->value.function.name = gfc_get_string (PREFIX ("ctime"));
 730 }
 731
 732
 733 void
 734 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
 735 {
 736   f->ts.type = BT_REAL;
 737   f->ts.kind = gfc_default_double_kind;
 738   f->value.function.name
 739     = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 740 }
 741
 742
 743 void
 744 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
 745 {
 746   f->ts.type = a->ts.type;
 747   if (p != NULL)
 748     f->ts.kind = gfc_kind_max (a,p);
 749   else
 750     f->ts.kind = a->ts.kind;
 751
 752   if (p != NULL && a->ts.kind != p->ts.kind)
 753     {
 754       if (a->ts.kind == gfc_kind_max (a,p))
 755         gfc_convert_type (p, &a->ts, 2);
 756       else
 757         gfc_convert_type (a, &p->ts, 2);
 758     }
 759
 760   f->value.function.name
 761     = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
 762 }
 763
 764
 765 void
 766 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
 767 {
 768   gfc_expr temp;
 769
 770   temp.expr_type = EXPR_OP;
 771   gfc_clear_ts (&temp.ts);
 772   temp.value.op.op = INTRINSIC_NONE;
 773   temp.value.op.op1 = a;
 774   temp.value.op.op2 = b;
 775   gfc_type_convert_binary (&temp, 1);
 776   f->ts = temp.ts;
 777   f->value.function.name
 778     = gfc_get_string (PREFIX ("dot_product_%c%d"),
 779                       gfc_type_letter (f->ts.type), f->ts.kind);
 780 }
 781
 782
 783 void
 784 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
 785                    gfc_expr *b ATTRIBUTE_UNUSED)
 786 {
 787   f->ts.kind = gfc_default_double_kind;
 788   f->ts.type = BT_REAL;
 789   f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
 790 }
 791
 792
 793 void
 794 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
 795                      gfc_expr *boundary, gfc_expr *dim)
 796 {
 797   int n, m;
 798
 799   if (array->ts.type == BT_CHARACTER && array->ref)
 800     gfc_resolve_substring_charlen (array);
 801
 802   f->ts = array->ts;
 803   f->rank = array->rank;
 804   f->shape = gfc_copy_shape (array->shape, array->rank);
 805
 806   n = 0;
 807   if (shift->rank > 0)
 808     n = n | 1;
 809   if (boundary && boundary->rank > 0)
 810     n = n | 2;
 811
 812   /* If dim kind is greater than default integer we need to use the larger.  */
 813   m = gfc_default_integer_kind;
 814   if (dim != NULL)
 815     m = m < dim->ts.kind ? dim->ts.kind : m;
 816
 817   /* Convert shift to at least m, so we don't need
 818       kind=1 and kind=2 versions of the library functions.  */
 819   if (shift->ts.kind < m)
 820     {
 821       gfc_typespec ts;
 822       gfc_clear_ts (&ts);
 823       ts.type = BT_INTEGER;
 824       ts.kind = m;
 825       gfc_convert_type_warn (shift, &ts, 2, 0);
 826     }
 827
 828   if (dim != NULL)
 829     {
 830       if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
 831           && dim->symtree->n.sym->attr.optional)
 832         {
 833           /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
 834           dim->representation.length = shift->ts.kind;
 835         }
 836       else
 837         {
 838           gfc_resolve_dim_arg (dim);
 839           /* Convert dim to shift's kind to reduce variations.  */
 840           if (dim->ts.kind != shift->ts.kind)
 841             gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 842         }
 843     }
 844
 845   if (array->ts.type == BT_CHARACTER)
 846     {
 847       if (array->ts.kind == gfc_default_character_kind)
 848         f->value.function.name
 849           = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
 850       else
 851         f->value.function.name
 852           = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
 853                             array->ts.kind);
 854     }
 855   else
 856     f->value.function.name
 857         = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
 858 }
 859
 860
 861 void
 862 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
 863 {
 864   f->ts = x->ts;
 865   f->value.function.name
 866     = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 867 }
 868
 869
 870 void
 871 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
 872 {
 873   f->ts.type = BT_INTEGER;
 874   f->ts.kind = gfc_default_integer_kind;
 875   f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
 876 }
 877
 878
 879 /* Resolve the EXTENDS_TYPE_OF intrinsic function.  */
 880
 881 void
 882 gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
 883 {
 884   gfc_symbol *vtab;
 885   gfc_symtree *st;
 886
 887   /* Prevent double resolution.  */
 888   if (f->ts.type == BT_LOGICAL)
 889     return;
 890
 891   /* Replace the first argument with the corresponding vtab.  */
 892   if (a->ts.type == BT_CLASS)
 893     gfc_add_component_ref (a, "$vptr");
 894   else if (a->ts.type == BT_DERIVED)
 895     {
 896       vtab = gfc_find_derived_vtab (a->ts.u.derived);
 897       /* Clear the old expr.  */
 898       gfc_free_ref_list (a->ref);
 899       memset (a, '\0', sizeof (gfc_expr));
 900       /* Construct a new one.  */
 901       a->expr_type = EXPR_VARIABLE;
 902       st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
 903       a->symtree = st;
 904       a->ts = vtab->ts;
 905     }
 906
 907   /* Replace the second argument with the corresponding vtab.  */
 908   if (mo->ts.type == BT_CLASS)
 909     gfc_add_component_ref (mo, "$vptr");
 910   else if (mo->ts.type == BT_DERIVED)
 911     {
 912       vtab = gfc_find_derived_vtab (mo->ts.u.derived);
 913       /* Clear the old expr.  */
 914       gfc_free_ref_list (mo->ref);
 915       memset (mo, '\0', sizeof (gfc_expr));
 916       /* Construct a new one.  */
 917       mo->expr_type = EXPR_VARIABLE;
 918       st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
 919       mo->symtree = st;
 920       mo->ts = vtab->ts;
 921     }
 922
 923   f->ts.type = BT_LOGICAL;
 924   f->ts.kind = 4;
 925
 926   f->value.function.isym->formal->ts = a->ts;
 927   f->value.function.isym->formal->next->ts = mo->ts;
 928
 929   /* Call library function.  */
 930   f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
 931 }
 932
 933
 934 void
 935 gfc_resolve_fdate (gfc_expr *f)
 936 {
 937   f->ts.type = BT_CHARACTER;
 938   f->ts.kind = gfc_default_character_kind;
 939   f->value.function.name = gfc_get_string (PREFIX ("fdate"));
 940 }
 941
 942
 943 void
 944 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 945 {
 946   f->ts.type = BT_INTEGER;
 947   f->ts.kind = (kind == NULL)
 948              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
 949   f->value.function.name
 950     = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
 951                       gfc_type_letter (a->ts.type), a->ts.kind);
 952 }
 953
 954
 955 void
 956 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
 957 {
 958   f->ts.type = BT_INTEGER;
 959   f->ts.kind = gfc_default_integer_kind;
 960   if (n->ts.kind != f->ts.kind)
 961     gfc_convert_type (n, &f->ts, 2);
 962   f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
 963 }
 964
 965
 966 void
 967 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
 968 {
 969   f->ts = x->ts;
 970   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 971 }
 972
 973
 974 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 975
 976 void
 977 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
 978 {
 979   f->ts = x->ts;
 980   f->value.function.name = gfc_get_string ("<intrinsic>");
 981 }
 982
 983
 984 void
 985 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
 986 {
 987   f->ts = x->ts;
 988   f->value.function.name
 989     = gfc_get_string ("__tgamma_%d", x->ts.kind);
 990 }
 991
 992
 993 void
 994 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 995 {
 996   f->ts.type = BT_INTEGER;
 997   f->ts.kind = 4;
 998   f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
 999 }
1000
1001
1002 void
1003 gfc_resolve_getgid (gfc_expr *f)
1004 {
1005   f->ts.type = BT_INTEGER;
1006   f->ts.kind = 4;
1007   f->value.function.name = gfc_get_string (PREFIX ("getgid"));
1008 }
1009
1010
1011 void
1012 gfc_resolve_getpid (gfc_expr *f)
1013 {
1014   f->ts.type = BT_INTEGER;
1015   f->ts.kind = 4;
1016   f->value.function.name = gfc_get_string (PREFIX ("getpid"));
1017 }
1018
1019
1020 void
1021 gfc_resolve_getuid (gfc_expr *f)
1022 {
1023   f->ts.type = BT_INTEGER;
1024   f->ts.kind = 4;
1025   f->value.function.name = gfc_get_string (PREFIX ("getuid"));
1026 }
1027
1028
1029 void
1030 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1031 {
1032   f->ts.type = BT_INTEGER;
1033   f->ts.kind = 4;
1034   f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
1035 }
1036
1037
1038 void
1039 gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
1040 {
1041   f->ts = x->ts;
1042   f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
1043 }
1044
1045
1046 void
1047 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1048 {
1049   /* If the kind of i and j are different, then g77 cross-promoted the
1050      kinds to the largest value.  The Fortran 95 standard requires the
1051      kinds to match.  */
1052   if (i->ts.kind != j->ts.kind)
1053     {
1054       if (i->ts.kind == gfc_kind_max (i, j))
1055         gfc_convert_type (j, &i->ts, 2);
1056       else
1057         gfc_convert_type (i, &j->ts, 2);
1058     }
1059
1060   f->ts = i->ts;
1061   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
1062 }
1063
1064
1065 void
1066 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1067 {
1068   f->ts = i->ts;
1069   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
1070 }
1071
1072
1073 void
1074 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1075                    gfc_expr *len ATTRIBUTE_UNUSED)
1076 {
1077   f->ts = i->ts;
1078   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
1079 }
1080
1081
1082 void
1083 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1084 {
1085   f->ts = i->ts;
1086   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
1087 }
1088
1089
1090 void
1091 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1092 {
1093   f->ts.type = BT_INTEGER;
1094   if (kind)
1095     f->ts.kind = mpz_get_si (kind->value.integer);
1096   else
1097     f->ts.kind = gfc_default_integer_kind;
1098   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1099 }
1100
1101
1102 void
1103 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1104 {
1105   f->ts.type = BT_INTEGER;
1106   if (kind)
1107     f->ts.kind = mpz_get_si (kind->value.integer);
1108   else
1109     f->ts.kind = gfc_default_integer_kind;
1110   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1111 }
1112
1113
1114 void
1115 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1116 {
1117   gfc_resolve_nint (f, a, NULL);
1118 }
1119
1120
1121 void
1122 gfc_resolve_ierrno (gfc_expr *f)
1123 {
1124   f->ts.type = BT_INTEGER;
1125   f->ts.kind = gfc_default_integer_kind;
1126   f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1127 }
1128
1129
1130 void
1131 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1132 {
1133   /* If the kind of i and j are different, then g77 cross-promoted the
1134      kinds to the largest value.  The Fortran 95 standard requires the
1135      kinds to match.  */
1136   if (i->ts.kind != j->ts.kind)
1137     {
1138       if (i->ts.kind == gfc_kind_max (i, j))
1139         gfc_convert_type (j, &i->ts, 2);
1140       else
1141         gfc_convert_type (i, &j->ts, 2);
1142     }
1143
1144   f->ts = i->ts;
1145   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
1146 }
1147
1148
1149 void
1150 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1151 {
1152   /* If the kind of i and j are different, then g77 cross-promoted the
1153      kinds to the largest value.  The Fortran 95 standard requires the
1154      kinds to match.  */
1155   if (i->ts.kind != j->ts.kind)
1156     {
1157       if (i->ts.kind == gfc_kind_max (i, j))
1158         gfc_convert_type (j, &i->ts, 2);
1159       else
1160         gfc_convert_type (i, &j->ts, 2);
1161     }
1162
1163   f->ts = i->ts;
1164   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
1165 }
1166
1167
1168 void
1169 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1170                         gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1171                         gfc_expr *kind)
1172 {
1173   gfc_typespec ts;
1174   gfc_clear_ts (&ts);
1175
1176   f->ts.type = BT_INTEGER;
1177   if (kind)
1178     f->ts.kind = mpz_get_si (kind->value.integer);
1179   else
1180     f->ts.kind = gfc_default_integer_kind;
1181
1182   if (back && back->ts.kind != gfc_default_integer_kind)
1183     {
1184       ts.type = BT_LOGICAL;
1185       ts.kind = gfc_default_integer_kind;
1186       ts.u.derived = NULL;
1187       ts.u.cl = NULL;
1188       gfc_convert_type (back, &ts, 2);
1189     }
1190
1191   f->value.function.name
1192     = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1193 }
1194
1195
1196 void
1197 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1198 {
1199   f->ts.type = BT_INTEGER;
1200   f->ts.kind = (kind == NULL)
1201              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1202   f->value.function.name
1203     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1204                       gfc_type_letter (a->ts.type), a->ts.kind);
1205 }
1206
1207
1208 void
1209 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1210 {
1211   f->ts.type = BT_INTEGER;
1212   f->ts.kind = 2;
1213   f->value.function.name
1214     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1215                       gfc_type_letter (a->ts.type), a->ts.kind);
1216 }
1217
1218
1219 void
1220 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1221 {
1222   f->ts.type = BT_INTEGER;
1223   f->ts.kind = 8;
1224   f->value.function.name
1225     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1226                       gfc_type_letter (a->ts.type), a->ts.kind);
1227 }
1228
1229
1230 void
1231 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1232 {
1233   f->ts.type = BT_INTEGER;
1234   f->ts.kind = 4;
1235   f->value.function.name
1236     = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1237                       gfc_type_letter (a->ts.type), a->ts.kind);
1238 }
1239
1240
1241 void
1242 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1243 {
1244   gfc_typespec ts;
1245   gfc_clear_ts (&ts);
1246
1247   f->ts.type = BT_LOGICAL;
1248   f->ts.kind = gfc_default_integer_kind;
1249   if (u->ts.kind != gfc_c_int_kind)
1250     {
1251       ts.type = BT_INTEGER;
1252       ts.kind = gfc_c_int_kind;
1253       ts.u.derived = NULL;
1254       ts.u.cl = NULL;
1255       gfc_convert_type (u, &ts, 2);
1256     }
1257
1258   f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1259 }
1260
1261
1262 void
1263 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1264 {
1265   f->ts = i->ts;
1266   f->value.function.name
1267     = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1268 }
1269
1270
1271 void
1272 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1273 {
1274   f->ts = i->ts;
1275   f->value.function.name
1276     = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1277 }
1278
1279
1280 void
1281 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1282 {
1283   f->ts = i->ts;
1284   f->value.function.name
1285     = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1286 }
1287
1288
1289 void
1290 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1291 {
1292   int s_kind;
1293
1294   s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1295
1296   f->ts = i->ts;
1297   f->value.function.name
1298     = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1299 }
1300
1301
1302 void
1303 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1304                   gfc_expr *s ATTRIBUTE_UNUSED)
1305 {
1306   f->ts.type = BT_INTEGER;
1307   f->ts.kind = gfc_default_integer_kind;
1308   f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1309 }
1310
1311
1312 void
1313 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1314 {
1315   resolve_bound (f, array, dim, kind, "__lbound", false);
1316 }
1317
1318
1319 void
1320 gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1321 {
1322   resolve_bound (f, array, dim, kind, "__lcobound", true);
1323 }
1324
1325
1326 void
1327 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1328 {
1329   f->ts.type = BT_INTEGER;
1330   if (kind)
1331     f->ts.kind = mpz_get_si (kind->value.integer);
1332   else
1333     f->ts.kind = gfc_default_integer_kind;
1334   f->value.function.name
1335     = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1336                       gfc_default_integer_kind);
1337 }
1338
1339
1340 void
1341 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1342 {
1343   f->ts.type = BT_INTEGER;
1344   if (kind)
1345     f->ts.kind = mpz_get_si (kind->value.integer);
1346   else
1347     f->ts.kind = gfc_default_integer_kind;
1348   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1349 }
1350
1351
1352 void
1353 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1354 {
1355   f->ts = x->ts;
1356   f->value.function.name
1357     = gfc_get_string ("__lgamma_%d", x->ts.kind);
1358 }
1359
1360
1361 void
1362 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1363                   gfc_expr *p2 ATTRIBUTE_UNUSED)
1364 {
1365   f->ts.type = BT_INTEGER;
1366   f->ts.kind = gfc_default_integer_kind;
1367   f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1368 }
1369
1370
1371 void
1372 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1373 {
1374   f->ts.type= BT_INTEGER;
1375   f->ts.kind = gfc_index_integer_kind;
1376   f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1377 }
1378
1379
1380 void
1381 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1382 {
1383   f->ts = x->ts;
1384   f->value.function.name
1385     = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1386 }
1387
1388
1389 void
1390 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1391 {
1392   f->ts = x->ts;
1393   f->value.function.name
1394     = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1395                       x->ts.kind);
1396 }
1397
1398
1399 void
1400 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1401 {
1402   f->ts.type = BT_LOGICAL;
1403   f->ts.kind = (kind == NULL)
1404              ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1405   f->rank = a->rank;
1406
1407   f->value.function.name
1408     = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1409                       gfc_type_letter (a->ts.type), a->ts.kind);
1410 }
1411
1412
1413 void
1414 gfc_resolve_malloc (gfc_expr *f, gfc_expr *size)
1415 {
1416   if (size->ts.kind < gfc_index_integer_kind)
1417     {
1418       gfc_typespec ts;
1419       gfc_clear_ts (&ts);
1420
1421       ts.type = BT_INTEGER;
1422       ts.kind = gfc_index_integer_kind;
1423       gfc_convert_type_warn (size, &ts, 2, 0);
1424     }
1425
1426   f->ts.type = BT_INTEGER;
1427   f->ts.kind = gfc_index_integer_kind;
1428   f->value.function.name = gfc_get_string (PREFIX ("malloc"));
1429 }
1430
1431
1432 void
1433 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1434 {
1435   gfc_expr temp;
1436
1437   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1438     {
1439       f->ts.type = BT_LOGICAL;
1440       f->ts.kind = gfc_default_logical_kind;
1441     }
1442   else
1443     {
1444       temp.expr_type = EXPR_OP;
1445       gfc_clear_ts (&temp.ts);
1446       temp.value.op.op = INTRINSIC_NONE;
1447       temp.value.op.op1 = a;
1448       temp.value.op.op2 = b;
1449       gfc_type_convert_binary (&temp, 1);
1450       f->ts = temp.ts;
1451     }
1452
1453   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1454
1455   if (a->rank == 2 && b->rank == 2)
1456     {
1457       if (a->shape && b->shape)
1458         {
1459           f->shape = gfc_get_shape (f->rank);
1460           mpz_init_set (f->shape[0], a->shape[0]);
1461           mpz_init_set (f->shape[1], b->shape[1]);
1462         }
1463     }
1464   else if (a->rank == 1)
1465     {
1466       if (b->shape)
1467         {
1468           f->shape = gfc_get_shape (f->rank);
1469           mpz_init_set (f->shape[0], b->shape[1]);
1470         }
1471     }
1472   else
1473     {
1474       /* b->rank == 1 and a->rank == 2 here, all other cases have
1475          been caught in check.c.   */
1476       if (a->shape)
1477         {
1478           f->shape = gfc_get_shape (f->rank);
1479           mpz_init_set (f->shape[0], a->shape[0]);
1480         }
1481     }
1482
1483   f->value.function.name
1484     = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1485                       f->ts.kind);
1486 }
1487
1488
1489 static void
1490 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1491 {
1492   gfc_actual_arglist *a;
1493
1494   f->ts.type = args->expr->ts.type;
1495   f->ts.kind = args->expr->ts.kind;
1496   /* Find the largest type kind.  */
1497   for (a = args->next; a; a = a->next)
1498     {
1499       if (a->expr->ts.kind > f->ts.kind)
1500         f->ts.kind = a->expr->ts.kind;
1501     }
1502
1503   /* Convert all parameters to the required kind.  */
1504   for (a = args; a; a = a->next)
1505     {
1506       if (a->expr->ts.kind != f->ts.kind)
1507         gfc_convert_type (a->expr, &f->ts, 2);
1508     }
1509
1510   f->value.function.name
1511     = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1512 }
1513
1514
1515 void
1516 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1517 {
1518   gfc_resolve_minmax ("__max_%c%d", f, args);
1519 }
1520
1521
1522 void
1523 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1524                     gfc_expr *mask)
1525 {
1526   const char *name;
1527   int i, j, idim;
1528
1529   f->ts.type = BT_INTEGER;
1530   f->ts.kind = gfc_default_integer_kind;
1531
1532   if (dim == NULL)
1533     {
1534       f->rank = 1;
1535       f->shape = gfc_get_shape (1);
1536       mpz_init_set_si (f->shape[0], array->rank);
1537     }
1538   else
1539     {
1540       f->rank = array->rank - 1;
1541       gfc_resolve_dim_arg (dim);
1542       if (array->shape && dim->expr_type == EXPR_CONSTANT)
1543         {
1544           idim = (int) mpz_get_si (dim->value.integer);
1545           f->shape = gfc_get_shape (f->rank);
1546           for (i = 0, j = 0; i < f->rank; i++, j++)
1547             {
1548               if (i == (idim - 1))
1549                 j++;
1550               mpz_init_set (f->shape[i], array->shape[j]);
1551             }
1552         }
1553     }
1554
1555   if (mask)
1556     {
1557       if (mask->rank == 0)
1558         name = "smaxloc";
1559       else
1560         name = "mmaxloc";
1561
1562       resolve_mask_arg (mask);
1563     }
1564   else
1565     name = "maxloc";
1566
1567   f->value.function.name
1568     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1569                       gfc_type_letter (array->ts.type), array->ts.kind);
1570 }
1571
1572
1573 void
1574 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1575                     gfc_expr *mask)
1576 {
1577   const char *name;
1578   int i, j, idim;
1579
1580   f->ts = array->ts;
1581
1582   if (dim != NULL)
1583     {
1584       f->rank = array->rank - 1;
1585       gfc_resolve_dim_arg (dim);
1586
1587       if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1588         {
1589           idim = (int) mpz_get_si (dim->value.integer);
1590           f->shape = gfc_get_shape (f->rank);
1591           for (i = 0, j = 0; i < f->rank; i++, j++)
1592             {
1593               if (i == (idim - 1))
1594                 j++;
1595               mpz_init_set (f->shape[i], array->shape[j]);
1596             }
1597         }
1598     }
1599
1600   if (mask)
1601     {
1602       if (mask->rank == 0)
1603         name = "smaxval";
1604       else
1605         name = "mmaxval";
1606
1607       resolve_mask_arg (mask);
1608     }
1609   else
1610     name = "maxval";
1611
1612   f->value.function.name
1613     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1614                       gfc_type_letter (array->ts.type), array->ts.kind);
1615 }
1616
1617
1618 void
1619 gfc_resolve_mclock (gfc_expr *f)
1620 {
1621   f->ts.type = BT_INTEGER;
1622   f->ts.kind = 4;
1623   f->value.function.name = PREFIX ("mclock");
1624 }
1625
1626
1627 void
1628 gfc_resolve_mclock8 (gfc_expr *f)
1629 {
1630   f->ts.type = BT_INTEGER;
1631   f->ts.kind = 8;
1632   f->value.function.name = PREFIX ("mclock8");
1633 }
1634
1635
1636 void
1637 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1638                    gfc_expr *fsource ATTRIBUTE_UNUSED,
1639                    gfc_expr *mask ATTRIBUTE_UNUSED)
1640 {
1641   if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1642     gfc_resolve_substring_charlen (tsource);
1643
1644   if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1645     gfc_resolve_substring_charlen (fsource);
1646
1647   if (tsource->ts.type == BT_CHARACTER)
1648     check_charlen_present (tsource);
1649
1650   f->ts = tsource->ts;
1651   f->value.function.name
1652     = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1653                       tsource->ts.kind);
1654 }
1655
1656
1657 void
1658 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1659 {
1660   gfc_resolve_minmax ("__min_%c%d", f, args);
1661 }
1662
1663
1664 void
1665 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1666                     gfc_expr *mask)
1667 {
1668   const char *name;
1669   int i, j, idim;
1670
1671   f->ts.type = BT_INTEGER;
1672   f->ts.kind = gfc_default_integer_kind;
1673
1674   if (dim == NULL)
1675     {
1676       f->rank = 1;
1677       f->shape = gfc_get_shape (1);
1678       mpz_init_set_si (f->shape[0], array->rank);
1679     }
1680   else
1681     {
1682       f->rank = array->rank - 1;
1683       gfc_resolve_dim_arg (dim);
1684       if (array->shape && dim->expr_type == EXPR_CONSTANT)
1685         {
1686           idim = (int) mpz_get_si (dim->value.integer);
1687           f->shape = gfc_get_shape (f->rank);
1688           for (i = 0, j = 0; i < f->rank; i++, j++)
1689             {
1690               if (i == (idim - 1))
1691                 j++;
1692               mpz_init_set (f->shape[i], array->shape[j]);
1693             }
1694         }
1695     }
1696
1697   if (mask)
1698     {
1699       if (mask->rank == 0)
1700         name = "sminloc";
1701       else
1702         name = "mminloc";
1703
1704       resolve_mask_arg (mask);
1705     }
1706   else
1707     name = "minloc";
1708
1709   f->value.function.name
1710     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1711                       gfc_type_letter (array->ts.type), array->ts.kind);
1712 }
1713
1714
1715 void
1716 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1717                     gfc_expr *mask)
1718 {
1719   const char *name;
1720   int i, j, idim;
1721
1722   f->ts = array->ts;
1723
1724   if (dim != NULL)
1725     {
1726       f->rank = array->rank - 1;
1727       gfc_resolve_dim_arg (dim);
1728
1729       if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1730         {
1731           idim = (int) mpz_get_si (dim->value.integer);
1732           f->shape = gfc_get_shape (f->rank);
1733           for (i = 0, j = 0; i < f->rank; i++, j++)
1734             {
1735               if (i == (idim - 1))
1736                 j++;
1737               mpz_init_set (f->shape[i], array->shape[j]);
1738             }
1739         }
1740     }
1741
1742   if (mask)
1743     {
1744       if (mask->rank == 0)
1745         name = "sminval";
1746       else
1747         name = "mminval";
1748
1749       resolve_mask_arg (mask);
1750     }
1751   else
1752     name = "minval";
1753
1754   f->value.function.name
1755     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1756                       gfc_type_letter (array->ts.type), array->ts.kind);
1757 }
1758
1759
1760 void
1761 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1762 {
1763   f->ts.type = a->ts.type;
1764   if (p != NULL)
1765     f->ts.kind = gfc_kind_max (a,p);
1766   else
1767     f->ts.kind = a->ts.kind;
1768
1769   if (p != NULL && a->ts.kind != p->ts.kind)
1770     {
1771       if (a->ts.kind == gfc_kind_max (a,p))
1772         gfc_convert_type (p, &a->ts, 2);
1773       else
1774         gfc_convert_type (a, &p->ts, 2);
1775     }
1776
1777   f->value.function.name
1778     = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1779 }
1780
1781
1782 void
1783 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1784 {
1785   f->ts.type = a->ts.type;
1786   if (p != NULL)
1787     f->ts.kind = gfc_kind_max (a,p);
1788   else
1789     f->ts.kind = a->ts.kind;
1790
1791   if (p != NULL && a->ts.kind != p->ts.kind)
1792     {
1793       if (a->ts.kind == gfc_kind_max (a,p))
1794         gfc_convert_type (p, &a->ts, 2);
1795       else
1796         gfc_convert_type (a, &p->ts, 2);
1797     }
1798
1799   f->value.function.name
1800     = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1801                       f->ts.kind);
1802 }
1803
1804 void
1805 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1806 {
1807   if (p->ts.kind != a->ts.kind)
1808     gfc_convert_type (p, &a->ts, 2);
1809
1810   f->ts = a->ts;
1811   f->value.function.name
1812     = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1813                       a->ts.kind);
1814 }
1815
1816 void
1817 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1818 {
1819   f->ts.type = BT_INTEGER;
1820   f->ts.kind = (kind == NULL)
1821              ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1822   f->value.function.name
1823     = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1824 }
1825
1826
1827 void
1828 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
1829 {
1830   f->ts = array->ts;
1831
1832   if (dim != NULL)
1833     {
1834       f->rank = array->rank - 1;
1835       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
1836       gfc_resolve_dim_arg (dim);
1837     }
1838
1839   f->value.function.name
1840     = gfc_get_string (PREFIX ("norm2_r%d"), array->ts.kind);
1841 }
1842
1843
1844 void
1845 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
1846 {
1847   f->ts = i->ts;
1848   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1849 }
1850
1851
1852 void
1853 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1854 {
1855   f->ts.type = i->ts.type;
1856   f->ts.kind = gfc_kind_max (i, j);
1857
1858   if (i->ts.kind != j->ts.kind)
1859     {
1860       if (i->ts.kind == gfc_kind_max (i, j))
1861         gfc_convert_type (j, &i->ts, 2);
1862       else
1863         gfc_convert_type (i, &j->ts, 2);
1864     }
1865
1866   f->value.function.name
1867     = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
1868 }
1869
1870
1871 void
1872 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
1873                   gfc_expr *vector ATTRIBUTE_UNUSED)
1874 {
1875   if (array->ts.type == BT_CHARACTER && array->ref)
1876     gfc_resolve_substring_charlen (array);
1877
1878   f->ts = array->ts;
1879   f->rank = 1;
1880
1881   resolve_mask_arg (mask);
1882
1883   if (mask->rank != 0)
1884     {
1885       if (array->ts.type == BT_CHARACTER)
1886         f->value.function.name
1887           = array->ts.kind == 1 ? PREFIX ("pack_char")
1888                                 : gfc_get_string
1889                                         (PREFIX ("pack_char%d"),
1890                                          array->ts.kind);
1891       else
1892         f->value.function.name = PREFIX ("pack");
1893     }
1894   else
1895     {
1896       if (array->ts.type == BT_CHARACTER)
1897         f->value.function.name
1898           = array->ts.kind == 1 ? PREFIX ("pack_s_char")
1899                                 : gfc_get_string
1900                                         (PREFIX ("pack_s_char%d"),
1901                                          array->ts.kind);
1902       else
1903         f->value.function.name = PREFIX ("pack_s");
1904     }
1905 }
1906
1907
1908 void
1909 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
1910 {
1911   f->ts = array->ts;
1912
1913   if (dim != NULL)
1914     {
1915       f->rank = array->rank - 1;
1916       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
1917       gfc_resolve_dim_arg (dim);
1918     }
1919
1920   resolve_mask_arg (array);
1921
1922   f->value.function.name
1923     = gfc_get_string (PREFIX ("parity_l%d"), array->ts.kind);
1924 }
1925
1926
1927 void
1928 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1929                      gfc_expr *mask)
1930 {
1931   const char *name;
1932
1933   f->ts = array->ts;
1934
1935   if (dim != NULL)
1936     {
1937       f->rank = array->rank - 1;
1938       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
1939       gfc_resolve_dim_arg (dim);
1940     }
1941
1942   if (mask)
1943     {
1944       if (mask->rank == 0)
1945         name = "sproduct";
1946       else
1947         name = "mproduct";
1948
1949       resolve_mask_arg (mask);
1950     }
1951   else
1952     name = "product";
1953
1954   f->value.function.name
1955     = gfc_get_string (PREFIX ("%s_%c%d"), name,
1956                       gfc_type_letter (array->ts.type), array->ts.kind);
1957 }
1958
1959
1960 void
1961 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1962 {
1963   f->ts.type = BT_REAL;
1964
1965   if (kind != NULL)
1966     f->ts.kind = mpz_get_si (kind->value.integer);
1967   else
1968     f->ts.kind = (a->ts.type == BT_COMPLEX)
1969                ? a->ts.kind : gfc_default_real_kind;
1970
1971   f->value.function.name
1972     = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1973                       gfc_type_letter (a->ts.type), a->ts.kind);
1974 }
1975
1976
1977 void
1978 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
1979 {
1980   f->ts.type = BT_REAL;
1981   f->ts.kind = a->ts.kind;
1982   f->value.function.name
1983     = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1984                       gfc_type_letter (a->ts.type), a->ts.kind);
1985 }
1986
1987
1988 void
1989 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1990                     gfc_expr *p2 ATTRIBUTE_UNUSED)
1991 {
1992   f->ts.type = BT_INTEGER;
1993   f->ts.kind = gfc_default_integer_kind;
1994   f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
1995 }
1996
1997
1998 void
1999 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2000                     gfc_expr *ncopies ATTRIBUTE_UNUSED)
2001 {
2002   f->ts.type = BT_CHARACTER;
2003   f->ts.kind = string->ts.kind;
2004   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2005 }
2006
2007
2008 void
2009 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2010                      gfc_expr *pad ATTRIBUTE_UNUSED,
2011                      gfc_expr *order ATTRIBUTE_UNUSED)
2012 {
2013   mpz_t rank;
2014   int kind;
2015   int i;
2016
2017   if (source->ts.type == BT_CHARACTER && source->ref)
2018     gfc_resolve_substring_charlen (source);
2019
2020   f->ts = source->ts;
2021
2022   gfc_array_size (shape, &rank);
2023   f->rank = mpz_get_si (rank);
2024   mpz_clear (rank);
2025   switch (source->ts.type)
2026     {
2027     case BT_COMPLEX:
2028     case BT_REAL:
2029     case BT_INTEGER:
2030     case BT_LOGICAL:
2031     case BT_CHARACTER:
2032       kind = source->ts.kind;
2033       break;
2034
2035     default:
2036       kind = 0;
2037       break;
2038     }
2039
2040   switch (kind)
2041     {
2042     case 4:
2043     case 8:
2044     case 10:
2045     case 16:
2046       if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2047         f->value.function.name
2048           = gfc_get_string (PREFIX ("reshape_%c%d"),
2049                             gfc_type_letter (source->ts.type),
2050                             source->ts.kind);
2051       else if (source->ts.type == BT_CHARACTER)
2052         f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2053                                                  kind);
2054       else
2055         f->value.function.name
2056           = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2057       break;
2058
2059     default:
2060       f->value.function.name = (source->ts.type == BT_CHARACTER
2061                                 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2062       break;
2063     }
2064
2065   /* TODO: Make this work with a constant ORDER parameter.  */
2066   if (shape->expr_type == EXPR_ARRAY
2067       && gfc_is_constant_expr (shape)
2068       && order == NULL)
2069     {
2070       gfc_constructor *c;
2071       f->shape = gfc_get_shape (f->rank);
2072       c = gfc_constructor_first (shape->value.constructor);
2073       for (i = 0; i < f->rank; i++)
2074         {
2075           mpz_init_set (f->shape[i], c->expr->value.integer);
2076           c = gfc_constructor_next (c);
2077         }
2078     }
2079
2080   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2081      so many runtime variations.  */
2082   if (shape->ts.kind != gfc_index_integer_kind)
2083     {
2084       gfc_typespec ts = shape->ts;
2085       ts.kind = gfc_index_integer_kind;
2086       gfc_convert_type_warn (shape, &ts, 2, 0);
2087     }
2088   if (order && order->ts.kind != gfc_index_integer_kind)
2089     gfc_convert_type_warn (order, &shape->ts, 2, 0);
2090 }
2091
2092
2093 void
2094 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2095 {
2096   f->ts = x->ts;
2097   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2098 }
2099
2100
2101 void
2102 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2103 {
2104   f->ts = x->ts;
2105   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2106 }
2107
2108
2109 void
2110 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2111                   gfc_expr *set ATTRIBUTE_UNUSED,
2112                   gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2113 {
2114   f->ts.type = BT_INTEGER;
2115   if (kind)
2116     f->ts.kind = mpz_get_si (kind->value.integer);
2117   else
2118     f->ts.kind = gfc_default_integer_kind;
2119   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2120 }
2121
2122
2123 void
2124 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2125 {
2126   t1->ts = t0->ts;
2127   t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2128 }
2129
2130
2131 void
2132 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2133                           gfc_expr *i ATTRIBUTE_UNUSED)
2134 {
2135   f->ts = x->ts;
2136   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2137 }
2138
2139
2140 void
2141 gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
2142 {
2143   f->ts.type = BT_INTEGER;
2144   f->ts.kind = gfc_default_integer_kind;
2145   f->rank = 1;
2146   f->shape = gfc_get_shape (1);
2147   mpz_init_set_ui (f->shape[0], array->rank);
2148   f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2149 }
2150
2151
2152 void
2153 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2154 {
2155   f->ts = a->ts;
2156   f->value.function.name
2157     = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2158 }
2159
2160
2161 void
2162 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2163 {
2164   f->ts.type = BT_INTEGER;
2165   f->ts.kind = gfc_c_int_kind;
2166
2167   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2168   if (handler->ts.type == BT_INTEGER)
2169     {
2170       if (handler->ts.kind != gfc_c_int_kind)
2171         gfc_convert_type (handler, &f->ts, 2);
2172       f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2173     }
2174   else
2175     f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2176
2177   if (number->ts.kind != gfc_c_int_kind)
2178     gfc_convert_type (number, &f->ts, 2);
2179 }
2180
2181
2182 void
2183 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2184 {
2185   f->ts = x->ts;
2186   f->value.function.name
2187     = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2188 }
2189
2190
2191 void
2192 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2193 {
2194   f->ts = x->ts;
2195   f->value.function.name
2196     = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2197 }
2198
2199
2200 void
2201 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2202                   gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2203 {
2204   f->ts.type = BT_INTEGER;
2205   if (kind)
2206     f->ts.kind = mpz_get_si (kind->value.integer);
2207   else
2208     f->ts.kind = gfc_default_integer_kind;
2209 }
2210
2211
2212 void
2213 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2214 {
2215   f->ts = x->ts;
2216   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2217 }
2218
2219
2220 void
2221 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2222                     gfc_expr *ncopies)
2223 {
2224   if (source->ts.type == BT_CHARACTER && source->ref)
2225     gfc_resolve_substring_charlen (source);
2226
2227   if (source->ts.type == BT_CHARACTER)
2228     check_charlen_present (source);
2229
2230   f->ts = source->ts;
2231   f->rank = source->rank + 1;
2232   if (source->rank == 0)
2233     {
2234       if (source->ts.type == BT_CHARACTER)
2235         f->value.function.name
2236           = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2237                                  : gfc_get_string
2238                                         (PREFIX ("spread_char%d_scalar"),
2239                                          source->ts.kind);
2240       else
2241         f->value.function.name = PREFIX ("spread_scalar");
2242     }
2243   else
2244     {
2245       if (source->ts.type == BT_CHARACTER)
2246         f->value.function.name
2247           = source->ts.kind == 1 ? PREFIX ("spread_char")
2248                                  : gfc_get_string
2249                                         (PREFIX ("spread_char%d"),
2250                                          source->ts.kind);
2251       else
2252         f->value.function.name = PREFIX ("spread");
2253     }
2254
2255   if (dim && gfc_is_constant_expr (dim)
2256       && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2257     {
2258       int i, idim;
2259       idim = mpz_get_ui (dim->value.integer);
2260       f->shape = gfc_get_shape (f->rank);
2261       for (i = 0; i < (idim - 1); i++)
2262         mpz_init_set (f->shape[i], source->shape[i]);
2263
2264       mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2265
2266       for (i = idim; i < f->rank ; i++)
2267         mpz_init_set (f->shape[i], source->shape[i-1]);
2268     }
2269
2270
2271   gfc_resolve_dim_arg (dim);
2272   gfc_resolve_index (ncopies, 1);
2273 }
2274
2275
2276 void
2277 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2278 {
2279   f->ts = x->ts;
2280   f->value.function.name
2281     = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2282 }
2283
2284
2285 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
2286
2287 void
2288 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2289                   gfc_expr *a ATTRIBUTE_UNUSED)
2290 {
2291   f->ts.type = BT_INTEGER;
2292   f->ts.kind = gfc_default_integer_kind;
2293   f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2294 }
2295
2296
2297 void
2298 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2299                    gfc_expr *a ATTRIBUTE_UNUSED)
2300 {
2301   f->ts.type = BT_INTEGER;
2302   f->ts.kind = gfc_default_integer_kind;
2303   f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2304 }
2305
2306
2307 void
2308 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2309 {
2310   f->ts.type = BT_INTEGER;
2311   f->ts.kind = gfc_default_integer_kind;
2312   if (n->ts.kind != f->ts.kind)
2313     gfc_convert_type (n, &f->ts, 2);
2314
2315   f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2316 }
2317
2318
2319 void
2320 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2321 {
2322   gfc_typespec ts;
2323   gfc_clear_ts (&ts);
2324
2325   f->ts.type = BT_INTEGER;
2326   f->ts.kind = gfc_c_int_kind;
2327   if (u->ts.kind != gfc_c_int_kind)
2328     {
2329       ts.type = BT_INTEGER;
2330       ts.kind = gfc_c_int_kind;
2331       ts.u.derived = NULL;
2332       ts.u.cl = NULL;
2333       gfc_convert_type (u, &ts, 2);
2334     }
2335
2336   f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2337 }
2338
2339
2340 void
2341 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2342 {
2343   f->ts.type = BT_INTEGER;
2344   f->ts.kind = gfc_c_int_kind;
2345   f->value.function.name = gfc_get_string (PREFIX ("fget"));
2346 }
2347
2348
2349 void
2350 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2351 {
2352   gfc_typespec ts;
2353   gfc_clear_ts (&ts);
2354
2355   f->ts.type = BT_INTEGER;
2356   f->ts.kind = gfc_c_int_kind;
2357   if (u->ts.kind != gfc_c_int_kind)
2358     {
2359       ts.type = BT_INTEGER;
2360       ts.kind = gfc_c_int_kind;
2361       ts.u.derived = NULL;
2362       ts.u.cl = NULL;
2363       gfc_convert_type (u, &ts, 2);
2364     }
2365
2366   f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2367 }
2368
2369
2370 void
2371 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2372 {
2373   f->ts.type = BT_INTEGER;
2374   f->ts.kind = gfc_c_int_kind;
2375   f->value.function.name = gfc_get_string (PREFIX ("fput"));
2376 }
2377
2378
2379 void
2380 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2381 {
2382   gfc_typespec ts;
2383   gfc_clear_ts (&ts);
2384
2385   f->ts.type = BT_INTEGER;
2386   f->ts.kind = gfc_index_integer_kind;
2387   if (u->ts.kind != gfc_c_int_kind)
2388     {
2389       ts.type = BT_INTEGER;
2390       ts.kind = gfc_c_int_kind;
2391       ts.u.derived = NULL;
2392       ts.u.cl = NULL;
2393       gfc_convert_type (u, &ts, 2);
2394     }
2395
2396   f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2397 }
2398
2399
2400 void
2401 gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2402                           gfc_expr *kind)
2403 {
2404   f->ts.type = BT_INTEGER;
2405   if (kind)
2406     f->ts.kind = mpz_get_si (kind->value.integer);
2407   else
2408     f->ts.kind = gfc_default_integer_kind;
2409 }
2410
2411
2412 void
2413 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2414 {
2415   const char *name;
2416
2417   f->ts = array->ts;
2418
2419   if (mask)
2420     {
2421       if (mask->rank == 0)
2422         name = "ssum";
2423       else
2424         name = "msum";
2425
2426       resolve_mask_arg (mask);
2427     }
2428   else
2429     name = "sum";
2430
2431   if (dim != NULL)
2432     {
2433       f->rank = array->rank - 1;
2434       f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
2435       gfc_resolve_dim_arg (dim);
2436     }
2437
2438   f->value.function.name
2439     = gfc_get_string (PREFIX ("%s_%c%d"), name,
2440                     gfc_type_letter (array->ts.type), array->ts.kind);
2441 }
2442
2443
2444 void
2445 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2446                     gfc_expr *p2 ATTRIBUTE_UNUSED)
2447 {
2448   f->ts.type = BT_INTEGER;
2449   f->ts.kind = gfc_default_integer_kind;
2450   f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2451 }
2452
2453
2454 /* Resolve the g77 compatibility function SYSTEM.  */
2455
2456 void
2457 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2458 {
2459   f->ts.type = BT_INTEGER;
2460   f->ts.kind = 4;
2461   f->value.function.name = gfc_get_string (PREFIX ("system"));
2462 }
2463
2464
2465 void
2466 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2467 {
2468   f->ts = x->ts;
2469   f->value.function.name
2470     = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2471 }
2472
2473
2474 void
2475 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2476 {
2477   f->ts = x->ts;
2478   f->value.function.name
2479     = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2480 }
2481
2482
2483 void
2484 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2485                          gfc_expr *sub ATTRIBUTE_UNUSED)
2486 {
2487   static char this_image[] = "__image_index";
2488   f->ts.kind = gfc_default_integer_kind;
2489   f->value.function.name = this_image;
2490 }
2491
2492
2493 void
2494 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2495 {
2496   resolve_bound (f, array, dim, NULL, "__this_image", true);
2497 }
2498
2499
2500 void
2501 gfc_resolve_time (gfc_expr *f)
2502 {
2503   f->ts.type = BT_INTEGER;
2504   f->ts.kind = 4;
2505   f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2506 }
2507
2508
2509 void
2510 gfc_resolve_time8 (gfc_expr *f)
2511 {
2512   f->ts.type = BT_INTEGER;
2513   f->ts.kind = 8;
2514   f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2515 }
2516
2517
2518 void
2519 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2520                       gfc_expr *mold, gfc_expr *size)
2521 {
2522   /* TODO: Make this do something meaningful.  */
2523   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2524
2525   if (mold->ts.type == BT_CHARACTER
2526         && !mold->ts.u.cl->length
2527         && gfc_is_constant_expr (mold))
2528     {
2529       int len;
2530       if (mold->expr_type == EXPR_CONSTANT)
2531         {
2532           len = mold->value.character.length;
2533           mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2534                                                     NULL, len);
2535         }
2536       else
2537         {
2538           gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
2539           len = c->expr->value.character.length;
2540           mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2541                                                     NULL, len);
2542         }
2543     }
2544
2545   f->ts = mold->ts;
2546
2547   if (size == NULL && mold->rank == 0)
2548     {
2549       f->rank = 0;
2550       f->value.function.name = transfer0;
2551     }
2552   else
2553     {
2554       f->rank = 1;
2555       f->value.function.name = transfer1;
2556       if (size && gfc_is_constant_expr (size))
2557         {
2558           f->shape = gfc_get_shape (1);
2559           mpz_init_set (f->shape[0], size->value.integer);
2560         }
2561     }
2562 }
2563
2564
2565 void
2566 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2567 {
2568
2569   if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2570     gfc_resolve_substring_charlen (matrix);
2571
2572   f->ts = matrix->ts;
2573   f->rank = 2;
2574   if (matrix->shape)
2575     {
2576       f->shape = gfc_get_shape (2);
2577       mpz_init_set (f->shape[0], matrix->shape[1]);
2578       mpz_init_set (f->shape[1], matrix->shape[0]);
2579     }
2580
2581   switch (matrix->ts.kind)
2582     {
2583     case 4:
2584     case 8:
2585     case 10:
2586     case 16:
2587       switch (matrix->ts.type)
2588         {
2589         case BT_REAL:
2590         case BT_COMPLEX:
2591           f->value.function.name
2592             = gfc_get_string (PREFIX ("transpose_%c%d"),
2593                               gfc_type_letter (matrix->ts.type),
2594                               matrix->ts.kind);
2595           break;
2596
2597         case BT_INTEGER:
2598         case BT_LOGICAL:
2599           /* Use the integer routines for real and logical cases.  This
2600              assumes they all have the same alignment requirements.  */
2601           f->value.function.name
2602             = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
2603           break;
2604
2605         default:
2606           if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
2607             f->value.function.name = PREFIX ("transpose_char4");
2608           else
2609             f->value.function.name = PREFIX ("transpose");
2610           break;
2611         }
2612       break;
2613
2614     default:
2615       f->value.function.name = (matrix->ts.type == BT_CHARACTER
2616                                 ? PREFIX ("transpose_char")
2617                                 : PREFIX ("transpose"));
2618       break;
2619     }
2620 }
2621
2622
2623 void
2624 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
2625 {
2626   f->ts.type = BT_CHARACTER;
2627   f->ts.kind = string->ts.kind;
2628   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
2629 }
2630
2631
2632 void
2633 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2634 {
2635   resolve_bound (f, array, dim, kind, "__ubound", false);
2636 }
2637
2638
2639 void
2640 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2641 {
2642   resolve_bound (f, array, dim, kind, "__ucobound", true);
2643 }
2644
2645
2646 /* Resolve the g77 compatibility function UMASK.  */
2647
2648 void
2649 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
2650 {
2651   f->ts.type = BT_INTEGER;
2652   f->ts.kind = n->ts.kind;
2653   f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
2654 }
2655
2656
2657 /* Resolve the g77 compatibility function UNLINK.  */
2658
2659 void
2660 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2661 {
2662   f->ts.type = BT_INTEGER;
2663   f->ts.kind = 4;
2664   f->value.function.name = gfc_get_string (PREFIX ("unlink"));
2665 }
2666
2667
2668 void
2669 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
2670 {
2671   gfc_typespec ts;
2672   gfc_clear_ts (&ts);
2673
2674   f->ts.type = BT_CHARACTER;
2675   f->ts.kind = gfc_default_character_kind;
2676
2677   if (unit->ts.kind != gfc_c_int_kind)
2678     {
2679       ts.type = BT_INTEGER;
2680       ts.kind = gfc_c_int_kind;
2681       ts.u.derived = NULL;
2682       ts.u.cl = NULL;
2683       gfc_convert_type (unit, &ts, 2);
2684     }
2685
2686   f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
2687 }
2688
2689
2690 void
2691 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
2692                     gfc_expr *field ATTRIBUTE_UNUSED)
2693 {
2694   if (vector->ts.type == BT_CHARACTER && vector->ref)
2695     gfc_resolve_substring_charlen (vector);
2696
2697   f->ts = vector->ts;
2698   f->rank = mask->rank;
2699   resolve_mask_arg (mask);
2700
2701   if (vector->ts.type == BT_CHARACTER)
2702     {
2703       if (vector->ts.kind == 1)
2704         f->value.function.name
2705           = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
2706       else
2707         f->value.function.name
2708           = gfc_get_string (PREFIX ("unpack%d_char%d"),
2709                             field->rank > 0 ? 1 : 0, vector->ts.kind);
2710     }
2711   else
2712     f->value.function.name
2713       = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
2714 }
2715
2716
2717 void
2718 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
2719                     gfc_expr *set ATTRIBUTE_UNUSED,
2720                     gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2721 {
2722   f->ts.type = BT_INTEGER;
2723   if (kind)
2724     f->ts.kind = mpz_get_si (kind->value.integer);
2725   else
2726     f->ts.kind = gfc_default_integer_kind;
2727   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
2728 }
2729
2730
2731 void
2732 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2733 {
2734   f->ts.type = i->ts.type;
2735   f->ts.kind = gfc_kind_max (i, j);
2736
2737   if (i->ts.kind != j->ts.kind)
2738     {
2739       if (i->ts.kind == gfc_kind_max (i, j))
2740         gfc_convert_type (j, &i->ts, 2);
2741       else
2742         gfc_convert_type (i, &j->ts, 2);
2743     }
2744
2745   f->value.function.name
2746     = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2747 }
2748
2749
2750 /* Intrinsic subroutine resolution.  */
2751
2752 void
2753 gfc_resolve_alarm_sub (gfc_code *c)
2754 {
2755   const char *name;
2756   gfc_expr *seconds, *handler;
2757   gfc_typespec ts;
2758   gfc_clear_ts (&ts);
2759
2760   seconds = c->ext.actual->expr;
2761   handler = c->ext.actual->next->expr;
2762   ts.type = BT_INTEGER;
2763   ts.kind = gfc_c_int_kind;
2764
2765   /* handler can be either BT_INTEGER or BT_PROCEDURE.
2766      In all cases, the status argument is of default integer kind
2767      (enforced in check.c) so that the function suffix is fixed.  */
2768   if (handler->ts.type == BT_INTEGER)
2769     {
2770       if (handler->ts.kind != gfc_c_int_kind)
2771         gfc_convert_type (handler, &ts, 2);
2772       name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
2773                              gfc_default_integer_kind);
2774     }
2775   else
2776     name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
2777                            gfc_default_integer_kind);
2778
2779   if (seconds->ts.kind != gfc_c_int_kind)
2780     gfc_convert_type (seconds, &ts, 2);
2781
2782   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2783 }
2784
2785 void
2786 gfc_resolve_cpu_time (gfc_code *c)
2787 {
2788   const char *name;
2789   name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2790   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2791 }
2792
2793
2794 /* Create a formal arglist based on an actual one and set the INTENTs given.  */
2795
2796 static gfc_formal_arglist*
2797 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
2798 {
2799   gfc_formal_arglist* head;
2800   gfc_formal_arglist* tail;
2801   int i;
2802
2803   if (!actual)
2804     return NULL;
2805
2806   head = tail = gfc_get_formal_arglist ();
2807   for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
2808     {
2809       gfc_symbol* sym;
2810
2811       sym = gfc_new_symbol ("dummyarg", NULL);
2812       sym->ts = actual->expr->ts;
2813
2814       sym->attr.intent = ints[i];
2815       tail->sym = sym;
2816
2817       if (actual->next)
2818         tail->next = gfc_get_formal_arglist ();
2819     }
2820
2821   return head;
2822 }
2823
2824
2825 void
2826 gfc_resolve_mvbits (gfc_code *c)
2827 {
2828   static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
2829                                        INTENT_INOUT, INTENT_IN};
2830
2831   const char *name;
2832   gfc_typespec ts;
2833   gfc_clear_ts (&ts);
2834
2835   /* FROMPOS, LEN and TOPOS are restricted to small values.  As such,
2836      they will be converted so that they fit into a C int.  */
2837   ts.type = BT_INTEGER;
2838   ts.kind = gfc_c_int_kind;
2839   if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
2840     gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
2841   if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
2842     gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
2843   if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
2844     gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
2845
2846   /* TO and FROM are guaranteed to have the same kind parameter.  */
2847   name = gfc_get_string (PREFIX ("mvbits_i%d"),
2848                          c->ext.actual->expr->ts.kind);
2849   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2850   /* Mark as elemental subroutine as this does not happen automatically.  */
2851   c->resolved_sym->attr.elemental = 1;
2852
2853   /* Create a dummy formal arglist so the INTENTs are known later for purpose
2854      of creating temporaries.  */
2855   c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
2856 }
2857
2858
2859 void
2860 gfc_resolve_random_number (gfc_code *c)
2861 {
2862   const char *name;
2863   int kind;
2864
2865   kind = c->ext.actual->expr->ts.kind;
2866   if (c->ext.actual->expr->rank == 0)
2867     name = gfc_get_string (PREFIX ("random_r%d"), kind);
2868   else
2869     name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2870
2871   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2872 }
2873
2874
2875 void
2876 gfc_resolve_random_seed (gfc_code *c)
2877 {
2878   const char *name;
2879
2880   name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
2881   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2882 }
2883
2884
2885 void
2886 gfc_resolve_rename_sub (gfc_code *c)
2887 {
2888   const char *name;
2889   int kind;
2890
2891   if (c->ext.actual->next->next->expr != NULL)
2892     kind = c->ext.actual->next->next->expr->ts.kind;
2893   else
2894     kind = gfc_default_integer_kind;
2895
2896   name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2897   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2898 }
2899
2900
2901 void
2902 gfc_resolve_kill_sub (gfc_code *c)
2903 {
2904   const char *name;
2905   int kind;
2906
2907   if (c->ext.actual->next->next->expr != NULL)
2908     kind = c->ext.actual->next->next->expr->ts.kind;
2909   else
2910     kind = gfc_default_integer_kind;
2911
2912   name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2913   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2914 }
2915
2916
2917 void
2918 gfc_resolve_link_sub (gfc_code *c)
2919 {
2920   const char *name;
2921   int kind;
2922
2923   if (c->ext.actual->next->next->expr != NULL)
2924     kind = c->ext.actual->next->next->expr->ts.kind;
2925   else
2926     kind = gfc_default_integer_kind;
2927
2928   name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2929   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2930 }
2931
2932
2933 void
2934 gfc_resolve_symlnk_sub (gfc_code *c)
2935 {
2936   const char *name;
2937   int kind;
2938
2939   if (c->ext.actual->next->next->expr != NULL)
2940     kind = c->ext.actual->next->next->expr->ts.kind;
2941   else
2942     kind = gfc_default_integer_kind;
2943
2944   name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2945   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2946 }
2947
2948
2949 /* G77 compatibility subroutines dtime() and etime().  */
2950
2951 void
2952 gfc_resolve_dtime_sub (gfc_code *c)
2953 {
2954   const char *name;
2955   name = gfc_get_string (PREFIX ("dtime_sub"));
2956   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2957 }
2958
2959 void
2960 gfc_resolve_etime_sub (gfc_code *c)
2961 {
2962   const char *name;
2963   name = gfc_get_string (PREFIX ("etime_sub"));
2964   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2965 }
2966
2967
2968 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime().  */
2969
2970 void
2971 gfc_resolve_itime (gfc_code *c)
2972 {
2973   c->resolved_sym
2974     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2975                                                     gfc_default_integer_kind));
2976 }
2977
2978 void
2979 gfc_resolve_idate (gfc_code *c)
2980 {
2981   c->resolved_sym
2982     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2983                                                     gfc_default_integer_kind));
2984 }
2985
2986 void
2987 gfc_resolve_ltime (gfc_code *c)
2988 {
2989   c->resolved_sym
2990     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2991                                                     gfc_default_integer_kind));
2992 }
2993
2994 void
2995 gfc_resolve_gmtime (gfc_code *c)
2996 {
2997   c->resolved_sym
2998     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2999                                                     gfc_default_integer_kind));
3000 }
3001
3002
3003 /* G77 compatibility subroutine second().  */
3004
3005 void
3006 gfc_resolve_second_sub (gfc_code *c)
3007 {
3008   const char *name;
3009   name = gfc_get_string (PREFIX ("second_sub"));
3010   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3011 }
3012
3013
3014 void
3015 gfc_resolve_sleep_sub (gfc_code *c)
3016 {
3017   const char *name;
3018   int kind;
3019
3020   if (c->ext.actual->expr != NULL)
3021     kind = c->ext.actual->expr->ts.kind;
3022   else
3023     kind = gfc_default_integer_kind;
3024
3025   name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3026   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3027 }
3028
3029
3030 /* G77 compatibility function srand().  */
3031
3032 void
3033 gfc_resolve_srand (gfc_code *c)
3034 {
3035   const char *name;
3036   name = gfc_get_string (PREFIX ("srand"));
3037   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3038 }
3039
3040
3041 /* Resolve the getarg intrinsic subroutine.  */
3042
3043 void
3044 gfc_resolve_getarg (gfc_code *c)
3045 {
3046   const char *name;
3047
3048   if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3049     {
3050       gfc_typespec ts;
3051       gfc_clear_ts (&ts);
3052
3053       ts.type = BT_INTEGER;
3054       ts.kind = gfc_default_integer_kind;
3055
3056       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3057     }
3058
3059   name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3060   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3061 }
3062
3063
3064 /* Resolve the getcwd intrinsic subroutine.  */
3065
3066 void
3067 gfc_resolve_getcwd_sub (gfc_code *c)
3068 {
3069   const char *name;
3070   int kind;
3071
3072   if (c->ext.actual->next->expr != NULL)
3073     kind = c->ext.actual->next->expr->ts.kind;
3074   else
3075     kind = gfc_default_integer_kind;
3076
3077   name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3078   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3079 }
3080
3081
3082 /* Resolve the get_command intrinsic subroutine.  */
3083
3084 void
3085 gfc_resolve_get_command (gfc_code *c)
3086 {
3087   const char *name;
3088   int kind;
3089   kind = gfc_default_integer_kind;
3090   name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3091   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3092 }
3093
3094
3095 /* Resolve the get_command_argument intrinsic subroutine.  */
3096
3097 void
3098 gfc_resolve_get_command_argument (gfc_code *c)
3099 {
3100   const char *name;
3101   int kind;
3102   kind = gfc_default_integer_kind;
3103   name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3104   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3105 }
3106
3107
3108 /* Resolve the get_environment_variable intrinsic subroutine.  */
3109
3110 void
3111 gfc_resolve_get_environment_variable (gfc_code *code)
3112 {
3113   const char *name;
3114   int kind;
3115   kind = gfc_default_integer_kind;
3116   name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3117   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3118 }
3119
3120
3121 void
3122 gfc_resolve_signal_sub (gfc_code *c)
3123 {
3124   const char *name;
3125   gfc_expr *number, *handler, *status;
3126   gfc_typespec ts;
3127   gfc_clear_ts (&ts);
3128
3129   number = c->ext.actual->expr;
3130   handler = c->ext.actual->next->expr;
3131   status = c->ext.actual->next->next->expr;
3132   ts.type = BT_INTEGER;
3133   ts.kind = gfc_c_int_kind;
3134
3135   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
3136   if (handler->ts.type == BT_INTEGER)
3137     {
3138       if (handler->ts.kind != gfc_c_int_kind)
3139         gfc_convert_type (handler, &ts, 2);
3140       name = gfc_get_string (PREFIX ("signal_sub_int"));
3141     }
3142   else
3143     name = gfc_get_string (PREFIX ("signal_sub"));
3144
3145   if (number->ts.kind != gfc_c_int_kind)
3146     gfc_convert_type (number, &ts, 2);
3147   if (status != NULL && status->ts.kind != gfc_c_int_kind)
3148     gfc_convert_type (status, &ts, 2);
3149
3150   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3151 }
3152
3153
3154 /* Resolve the SYSTEM intrinsic subroutine.  */
3155
3156 void
3157 gfc_resolve_system_sub (gfc_code *c)
3158 {
3159   const char *name;
3160   name = gfc_get_string (PREFIX ("system_sub"));
3161   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3162 }
3163
3164
3165 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3166
3167 void
3168 gfc_resolve_system_clock (gfc_code *c)
3169 {
3170   const char *name;
3171   int kind;
3172
3173   if (c->ext.actual->expr != NULL)
3174     kind = c->ext.actual->expr->ts.kind;
3175   else if (c->ext.actual->next->expr != NULL)
3176       kind = c->ext.actual->next->expr->ts.kind;
3177   else if (c->ext.actual->next->next->expr != NULL)
3178       kind = c->ext.actual->next->next->expr->ts.kind;
3179   else
3180     kind = gfc_default_integer_kind;
3181
3182   name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3183   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3184 }
3185
3186
3187 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine.  */
3188 void
3189 gfc_resolve_execute_command_line (gfc_code *c)
3190 {
3191   const char *name;
3192   name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3193                          gfc_default_integer_kind);
3194   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3195 }
3196
3197
3198 /* Resolve the EXIT intrinsic subroutine.  */
3199
3200 void
3201 gfc_resolve_exit (gfc_code *c)
3202 {
3203   const char *name;
3204   gfc_typespec ts;
3205   gfc_expr *n;
3206   gfc_clear_ts (&ts);
3207
3208   /* The STATUS argument has to be of default kind.  If it is not,
3209      we convert it.  */
3210   ts.type = BT_INTEGER;
3211   ts.kind = gfc_default_integer_kind;
3212   n = c->ext.actual->expr;
3213   if (n != NULL && n->ts.kind != ts.kind)
3214     gfc_convert_type (n, &ts, 2);
3215
3216   name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3217   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3218 }
3219
3220
3221 /* Resolve the FLUSH intrinsic subroutine.  */
3222
3223 void
3224 gfc_resolve_flush (gfc_code *c)
3225 {
3226   const char *name;
3227   gfc_typespec ts;
3228   gfc_expr *n;
3229   gfc_clear_ts (&ts);
3230
3231   ts.type = BT_INTEGER;
3232   ts.kind = gfc_default_integer_kind;
3233   n = c->ext.actual->expr;
3234   if (n != NULL && n->ts.kind != ts.kind)
3235     gfc_convert_type (n, &ts, 2);
3236
3237   name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3238   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3239 }
3240
3241
3242 void
3243 gfc_resolve_free (gfc_code *c)
3244 {
3245   gfc_typespec ts;
3246   gfc_expr *n;
3247   gfc_clear_ts (&ts);
3248
3249   ts.type = BT_INTEGER;
3250   ts.kind = gfc_index_integer_kind;
3251   n = c->ext.actual->expr;
3252   if (n->ts.kind != ts.kind)
3253     gfc_convert_type (n, &ts, 2);
3254
3255   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
3256 }
3257
3258
3259 void
3260 gfc_resolve_ctime_sub (gfc_code *c)
3261 {
3262   gfc_typespec ts;
3263   gfc_clear_ts (&ts);
3264
3265   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3266   if (c->ext.actual->expr->ts.kind != 8)
3267     {
3268       ts.type = BT_INTEGER;
3269       ts.kind = 8;
3270       ts.u.derived = NULL;
3271       ts.u.cl = NULL;
3272       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3273     }
3274
3275   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3276 }
3277
3278
3279 void
3280 gfc_resolve_fdate_sub (gfc_code *c)
3281 {
3282   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3283 }
3284
3285
3286 void
3287 gfc_resolve_gerror (gfc_code *c)
3288 {
3289   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3290 }
3291
3292
3293 void
3294 gfc_resolve_getlog (gfc_code *c)
3295 {
3296   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3297 }
3298
3299
3300 void
3301 gfc_resolve_hostnm_sub (gfc_code *c)
3302 {
3303   const char *name;
3304   int kind;
3305
3306   if (c->ext.actual->next->expr != NULL)
3307     kind = c->ext.actual->next->expr->ts.kind;
3308   else
3309     kind = gfc_default_integer_kind;
3310
3311   name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3312   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3313 }
3314
3315
3316 void
3317 gfc_resolve_perror (gfc_code *c)
3318 {
3319   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3320 }
3321
3322 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
3323
3324 void
3325 gfc_resolve_stat_sub (gfc_code *c)
3326 {
3327   const char *name;
3328   name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3329   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3330 }
3331
3332
3333 void
3334 gfc_resolve_lstat_sub (gfc_code *c)
3335 {
3336   const char *name;
3337   name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3338   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3339 }
3340
3341
3342 void
3343 gfc_resolve_fstat_sub (gfc_code *c)
3344 {
3345   const char *name;
3346   gfc_expr *u;
3347   gfc_typespec *ts;
3348
3349   u = c->ext.actual->expr;
3350   ts = &c->ext.actual->next->expr->ts;
3351   if (u->ts.kind != ts->kind)
3352     gfc_convert_type (u, ts, 2);
3353   name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3354   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3355 }
3356
3357
3358 void
3359 gfc_resolve_fgetc_sub (gfc_code *c)
3360 {
3361   const char *name;
3362   gfc_typespec ts;
3363   gfc_expr *u, *st;
3364   gfc_clear_ts (&ts);
3365
3366   u = c->ext.actual->expr;
3367   st = c->ext.actual->next->next->expr;
3368
3369   if (u->ts.kind != gfc_c_int_kind)
3370     {
3371       ts.type = BT_INTEGER;
3372       ts.kind = gfc_c_int_kind;
3373       ts.u.derived = NULL;
3374       ts.u.cl = NULL;
3375       gfc_convert_type (u, &ts, 2);
3376     }
3377
3378   if (st != NULL)
3379     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3380   else
3381     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3382
3383   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3384 }
3385
3386
3387 void
3388 gfc_resolve_fget_sub (gfc_code *c)
3389 {
3390   const char *name;
3391   gfc_expr *st;
3392
3393   st = c->ext.actual->next->expr;
3394   if (st != NULL)
3395     name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3396   else
3397     name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3398
3399   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3400 }
3401
3402
3403 void
3404 gfc_resolve_fputc_sub (gfc_code *c)
3405 {
3406   const char *name;
3407   gfc_typespec ts;
3408   gfc_expr *u, *st;
3409   gfc_clear_ts (&ts);
3410
3411   u = c->ext.actual->expr;
3412   st = c->ext.actual->next->next->expr;
3413
3414   if (u->ts.kind != gfc_c_int_kind)
3415     {
3416       ts.type = BT_INTEGER;
3417       ts.kind = gfc_c_int_kind;
3418       ts.u.derived = NULL;
3419       ts.u.cl = NULL;
3420       gfc_convert_type (u, &ts, 2);
3421     }
3422
3423   if (st != NULL)
3424     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3425   else
3426     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3427
3428   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3429 }
3430
3431
3432 void
3433 gfc_resolve_fput_sub (gfc_code *c)
3434 {
3435   const char *name;
3436   gfc_expr *st;
3437
3438   st = c->ext.actual->next->expr;
3439   if (st != NULL)
3440     name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3441   else
3442     name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3443
3444   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3445 }
3446
3447
3448 void
3449 gfc_resolve_fseek_sub (gfc_code *c)
3450 {
3451   gfc_expr *unit;
3452   gfc_expr *offset;
3453   gfc_expr *whence;
3454   gfc_typespec ts;
3455   gfc_clear_ts (&ts);
3456
3457   unit   = c->ext.actual->expr;
3458   offset = c->ext.actual->next->expr;
3459   whence = c->ext.actual->next->next->expr;
3460
3461   if (unit->ts.kind != gfc_c_int_kind)
3462     {
3463       ts.type = BT_INTEGER;
3464       ts.kind = gfc_c_int_kind;
3465       ts.u.derived = NULL;
3466       ts.u.cl = NULL;
3467       gfc_convert_type (unit, &ts, 2);
3468     }
3469
3470   if (offset->ts.kind != gfc_intio_kind)
3471     {
3472       ts.type = BT_INTEGER;
3473       ts.kind = gfc_intio_kind;
3474       ts.u.derived = NULL;
3475       ts.u.cl = NULL;
3476       gfc_convert_type (offset, &ts, 2);
3477     }
3478
3479   if (whence->ts.kind != gfc_c_int_kind)
3480     {
3481       ts.type = BT_INTEGER;
3482       ts.kind = gfc_c_int_kind;
3483       ts.u.derived = NULL;
3484       ts.u.cl = NULL;
3485       gfc_convert_type (whence, &ts, 2);
3486     }
3487
3488   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3489 }
3490
3491 void
3492 gfc_resolve_ftell_sub (gfc_code *c)
3493 {
3494   const char *name;
3495   gfc_expr *unit;
3496   gfc_expr *offset;
3497   gfc_typespec ts;
3498   gfc_clear_ts (&ts);
3499
3500   unit = c->ext.actual->expr;
3501   offset = c->ext.actual->next->expr;
3502
3503   if (unit->ts.kind != gfc_c_int_kind)
3504     {
3505       ts.type = BT_INTEGER;
3506       ts.kind = gfc_c_int_kind;
3507       ts.u.derived = NULL;
3508       ts.u.cl = NULL;
3509       gfc_convert_type (unit, &ts, 2);
3510     }
3511
3512   name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3513   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3514 }
3515
3516
3517 void
3518 gfc_resolve_ttynam_sub (gfc_code *c)
3519 {
3520   gfc_typespec ts;
3521   gfc_clear_ts (&ts);
3522
3523   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3524     {
3525       ts.type = BT_INTEGER;
3526       ts.kind = gfc_c_int_kind;
3527       ts.u.derived = NULL;
3528       ts.u.cl = NULL;
3529       gfc_convert_type (c->ext.actual->expr, &ts, 2);
3530     }
3531
3532   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3533 }
3534
3535
3536 /* Resolve the UMASK intrinsic subroutine.  */
3537
3538 void
3539 gfc_resolve_umask_sub (gfc_code *c)
3540 {
3541   const char *name;
3542   int kind;
3543
3544   if (c->ext.actual->next->expr != NULL)
3545     kind = c->ext.actual->next->expr->ts.kind;
3546   else
3547     kind = gfc_default_integer_kind;
3548
3549   name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3550   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3551 }
3552
3553 /* Resolve the UNLINK intrinsic subroutine.  */
3554
3555 void
3556 gfc_resolve_unlink_sub (gfc_code *c)
3557 {
3558   const char *name;
3559   int kind;
3560
3561   if (c->ext.actual->next->expr != NULL)
3562     kind = c->ext.actual->next->expr->ts.kind;
3563   else
3564     kind = gfc_default_integer_kind;
3565
3566   name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3567   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3568 }