gcc/fortran/iresolve.c

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