gcc/fortran/iresolve.c

   1 /* Intrinsic function resolution.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   3    Inc.
   4    Contributed by Andy Vaught & Katherine Holcomb
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  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
  38
  39 /* Given printf-like arguments, return a stable version of the result string.
  40
  41    We already have a working, optimized string hashing table in the form of
  42    the identifier table.  Reusing this table is likely not to be wasted,
  43    since if the function name makes it to the gimple output of the frontend,
  44    we'll have to create the identifier anyway.  */
  45
  46 const char *
  47 gfc_get_string (const char *format, ...)
  48 {
  49   char temp_name[128];
  50   va_list ap;
  51   tree ident;
  52
  53   va_start (ap, format);
  54   vsnprintf (temp_name, sizeof(temp_name), format, ap);
  55   va_end (ap);
  56   temp_name[sizeof(temp_name)-1] = 0;
  57
  58   ident = get_identifier (temp_name);
  59   return IDENTIFIER_POINTER (ident);
  60 }
  61
  62 /* MERGE and SPREAD need to have source charlen's present for passing
  63    to the result expression.  */
  64 static void
  65 check_charlen_present (gfc_expr *source)
  66 {
  67   if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
  68     {
  69       source->ts.cl = gfc_get_charlen ();
  70       source->ts.cl->next = gfc_current_ns->cl_list;
  71       gfc_current_ns->cl_list = source->ts.cl;
  72       source->ts.cl->length = gfc_int_expr (source->value.character.length);
  73       source->rank = 0;
  74     }
  75 }
  76
  77 /********************** Resolution functions **********************/
  78
  79
  80 void
  81 gfc_resolve_abs (gfc_expr * f, gfc_expr * a)
  82 {
  83   f->ts = a->ts;
  84   if (f->ts.type == BT_COMPLEX)
  85     f->ts.type = BT_REAL;
  86
  87   f->value.function.name =
  88     gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
  89 }
  90
  91
  92 void
  93 gfc_resolve_acos (gfc_expr * f, gfc_expr * x)
  94 {
  95   f->ts = x->ts;
  96   f->value.function.name =
  97     gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
  98 }
  99
 100
 101 void
 102 gfc_resolve_acosh (gfc_expr * f, gfc_expr * x)
 103 {
 104   f->ts = x->ts;
 105   f->value.function.name =
 106     gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 107 }
 108
 109
 110 void
 111 gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
 112 {
 113   f->ts.type = BT_REAL;
 114   f->ts.kind = x->ts.kind;
 115   f->value.function.name =
 116     gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 117 }
 118
 119
 120 void
 121 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 122 {
 123   gfc_typespec ts;
 124
 125   f->ts.type = a->ts.type;
 126   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 127
 128   if (a->ts.kind != f->ts.kind)
 129     {
 130       ts.type = f->ts.type;
 131       ts.kind = f->ts.kind;
 132       gfc_convert_type (a, &ts, 2);
 133     }
 134   /* The resolved name is only used for specific intrinsics where
 135      the return kind is the same as the arg kind.  */
 136   f->value.function.name =
 137     gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 138 }
 139
 140
 141 void
 142 gfc_resolve_dint (gfc_expr * f, gfc_expr * a)
 143 {
 144   gfc_resolve_aint (f, a, NULL);
 145 }
 146
 147
 148 void
 149 gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 150 {
 151   f->ts = mask->ts;
 152
 153   if (dim != NULL)
 154     {
 155       gfc_resolve_dim_arg (dim);
 156       f->rank = mask->rank - 1;
 157       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 158     }
 159
 160   f->value.function.name =
 161     gfc_get_string (PREFIX("all_%c%d"), gfc_type_letter (mask->ts.type),
 162                     mask->ts.kind);
 163 }
 164
 165
 166 void
 167 gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 168 {
 169   gfc_typespec ts;
 170
 171   f->ts.type = a->ts.type;
 172   f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 173
 174   if (a->ts.kind != f->ts.kind)
 175     {
 176       ts.type = f->ts.type;
 177       ts.kind = f->ts.kind;
 178       gfc_convert_type (a, &ts, 2);
 179     }
 180
 181   /* The resolved name is only used for specific intrinsics where
 182      the return kind is the same as the arg kind.  */
 183   f->value.function.name =
 184     gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 185 }
 186
 187
 188 void
 189 gfc_resolve_dnint (gfc_expr * f, gfc_expr * a)
 190 {
 191   gfc_resolve_anint (f, a, NULL);
 192 }
 193
 194
 195 void
 196 gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 197 {
 198   f->ts = mask->ts;
 199
 200   if (dim != NULL)
 201     {
 202       gfc_resolve_dim_arg (dim);
 203       f->rank = mask->rank - 1;
 204       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 205     }
 206
 207   f->value.function.name =
 208     gfc_get_string (PREFIX("any_%c%d"), gfc_type_letter (mask->ts.type),
 209                     mask->ts.kind);
 210 }
 211
 212
 213 void
 214 gfc_resolve_asin (gfc_expr * f, gfc_expr * x)
 215 {
 216   f->ts = x->ts;
 217   f->value.function.name =
 218     gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 219 }
 220
 221 void
 222 gfc_resolve_asinh (gfc_expr * f, gfc_expr * x)
 223 {
 224   f->ts = x->ts;
 225   f->value.function.name =
 226     gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 227 }
 228
 229 void
 230 gfc_resolve_atan (gfc_expr * f, gfc_expr * x)
 231 {
 232   f->ts = x->ts;
 233   f->value.function.name =
 234     gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 235 }
 236
 237 void
 238 gfc_resolve_atanh (gfc_expr * f, gfc_expr * x)
 239 {
 240   f->ts = x->ts;
 241   f->value.function.name =
 242     gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 243 }
 244
 245 void
 246 gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x,
 247                    gfc_expr * y ATTRIBUTE_UNUSED)
 248 {
 249   f->ts = x->ts;
 250   f->value.function.name =
 251     gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 252 }
 253
 254
 255 /* Resolve the BESYN and BESJN intrinsics.  */
 256
 257 void
 258 gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x)
 259 {
 260   gfc_typespec ts;
 261
 262   f->ts = x->ts;
 263   if (n->ts.kind != gfc_c_int_kind)
 264     {
 265       ts.type = BT_INTEGER;
 266       ts.kind = gfc_c_int_kind;
 267       gfc_convert_type (n, &ts, 2);
 268     }
 269   f->value.function.name = gfc_get_string ("<intrinsic>");
 270 }
 271
 272
 273 void
 274 gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos)
 275 {
 276   f->ts.type = BT_LOGICAL;
 277   f->ts.kind = gfc_default_logical_kind;
 278
 279   f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind,
 280                                            pos->ts.kind);
 281 }
 282
 283
 284 void
 285 gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 286 {
 287   f->ts.type = BT_INTEGER;
 288   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 289     : mpz_get_si (kind->value.integer);
 290
 291   f->value.function.name =
 292     gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
 293                     gfc_type_letter (a->ts.type), a->ts.kind);
 294 }
 295
 296
 297 void
 298 gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 299 {
 300   f->ts.type = BT_CHARACTER;
 301   f->ts.kind = (kind == NULL) ? gfc_default_character_kind
 302     : mpz_get_si (kind->value.integer);
 303
 304   f->value.function.name =
 305     gfc_get_string ("__char_%d_%c%d", f->ts.kind,
 306                     gfc_type_letter (a->ts.type), a->ts.kind);
 307 }
 308
 309
 310 void
 311 gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
 312 {
 313   f->ts.type = BT_INTEGER;
 314   f->ts.kind = gfc_default_integer_kind;
 315   f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
 316 }
 317
 318
 319 void
 320 gfc_resolve_chdir_sub (gfc_code * c)
 321 {
 322   const char *name;
 323   int kind;
 324
 325   if (c->ext.actual->next->expr != NULL)
 326     kind = c->ext.actual->next->expr->ts.kind;
 327   else
 328     kind = gfc_default_integer_kind;
 329
 330   name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
 331   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 332 }
 333
 334
 335 void
 336 gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 337 {
 338   f->ts.type = BT_COMPLEX;
 339   f->ts.kind = (kind == NULL) ? gfc_default_real_kind
 340     : mpz_get_si (kind->value.integer);
 341
 342   if (y == NULL)
 343     f->value.function.name =
 344       gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
 345                       gfc_type_letter (x->ts.type), x->ts.kind);
 346   else
 347     f->value.function.name =
 348       gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
 349                       gfc_type_letter (x->ts.type), x->ts.kind,
 350                       gfc_type_letter (y->ts.type), y->ts.kind);
 351 }
 352
 353 void
 354 gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
 355 {
 356   gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
 357 }
 358
 359 void
 360 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
 361 {
 362   f->ts = x->ts;
 363   f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
 364 }
 365
 366
 367 void
 368 gfc_resolve_cos (gfc_expr * f, gfc_expr * x)
 369 {
 370   f->ts = x->ts;
 371   f->value.function.name =
 372     gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 373 }
 374
 375
 376 void
 377 gfc_resolve_cosh (gfc_expr * f, gfc_expr * x)
 378 {
 379   f->ts = x->ts;
 380   f->value.function.name =
 381     gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 382 }
 383
 384
 385 void
 386 gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
 387 {
 388   f->ts.type = BT_INTEGER;
 389   f->ts.kind = gfc_default_integer_kind;
 390
 391   if (dim != NULL)
 392     {
 393       f->rank = mask->rank - 1;
 394       gfc_resolve_dim_arg (dim);
 395       f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
 396     }
 397
 398   f->value.function.name =
 399     gfc_get_string (PREFIX("count_%d_%c%d"), f->ts.kind,
 400                     gfc_type_letter (mask->ts.type), mask->ts.kind);
 401 }
 402
 403
 404 void
 405 gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
 406                     gfc_expr * shift,
 407                     gfc_expr * dim)
 408 {
 409   int n;
 410
 411   f->ts = array->ts;
 412   f->rank = array->rank;
 413   f->shape = gfc_copy_shape (array->shape, array->rank);
 414
 415   if (shift->rank > 0)
 416     n = 1;
 417   else
 418     n = 0;
 419
 420   /* Convert shift to at least gfc_default_integer_kind, so we don't need
 421      kind=1 and kind=2 versions of the library functions.  */
 422   if (shift->ts.kind < gfc_default_integer_kind)
 423     {
 424       gfc_typespec ts;
 425       ts.type = BT_INTEGER;
 426       ts.kind = gfc_default_integer_kind;
 427       gfc_convert_type_warn (shift, &ts, 2, 0);
 428     }
 429
 430   if (dim != NULL)
 431     {
 432       gfc_resolve_dim_arg (dim);
 433       /* Convert dim to shift's kind, so we don't need so many variations.  */
 434       if (dim->ts.kind != shift->ts.kind)
 435         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 436     }
 437   f->value.function.name =
 438     gfc_get_string (PREFIX("cshift%d_%d%s"), n, shift->ts.kind,
 439                     array->ts.type == BT_CHARACTER ? "_char" : "");
 440 }
 441
 442
 443 void
 444 gfc_resolve_dble (gfc_expr * f, gfc_expr * a)
 445 {
 446   f->ts.type = BT_REAL;
 447   f->ts.kind = gfc_default_double_kind;
 448   f->value.function.name =
 449     gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
 450 }
 451
 452
 453 void
 454 gfc_resolve_dim (gfc_expr * f, gfc_expr * x,
 455                  gfc_expr * y ATTRIBUTE_UNUSED)
 456 {
 457   f->ts = x->ts;
 458   f->value.function.name =
 459     gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 460 }
 461
 462
 463 void
 464 gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 465 {
 466   gfc_expr temp;
 467
 468   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 469     {
 470       f->ts.type = BT_LOGICAL;
 471       f->ts.kind = gfc_default_logical_kind;
 472     }
 473   else
 474     {
 475       temp.expr_type = EXPR_OP;
 476       gfc_clear_ts (&temp.ts);
 477       temp.value.op.operator = INTRINSIC_NONE;
 478       temp.value.op.op1 = a;
 479       temp.value.op.op2 = b;
 480       gfc_type_convert_binary (&temp);
 481       f->ts = temp.ts;
 482     }
 483
 484   f->value.function.name =
 485     gfc_get_string (PREFIX("dot_product_%c%d"), gfc_type_letter (f->ts.type),
 486                     f->ts.kind);
 487 }
 488
 489
 490 void
 491 gfc_resolve_dprod (gfc_expr * f,
 492                    gfc_expr * a ATTRIBUTE_UNUSED,
 493                    gfc_expr * b ATTRIBUTE_UNUSED)
 494 {
 495   f->ts.kind = gfc_default_double_kind;
 496   f->ts.type = BT_REAL;
 497
 498   f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
 499 }
 500
 501
 502 void
 503 gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
 504                      gfc_expr * shift,
 505                      gfc_expr * boundary,
 506                      gfc_expr * dim)
 507 {
 508   int n;
 509
 510   f->ts = array->ts;
 511   f->rank = array->rank;
 512   f->shape = gfc_copy_shape (array->shape, array->rank);
 513
 514   n = 0;
 515   if (shift->rank > 0)
 516     n = n | 1;
 517   if (boundary && boundary->rank > 0)
 518     n = n | 2;
 519
 520   /* Convert shift to at least gfc_default_integer_kind, so we don't need
 521      kind=1 and kind=2 versions of the library functions.  */
 522   if (shift->ts.kind < gfc_default_integer_kind)
 523     {
 524       gfc_typespec ts;
 525       ts.type = BT_INTEGER;
 526       ts.kind = gfc_default_integer_kind;
 527       gfc_convert_type_warn (shift, &ts, 2, 0);
 528     }
 529
 530   if (dim != NULL)
 531     {
 532       gfc_resolve_dim_arg (dim);
 533       /* Convert dim to shift's kind, so we don't need so many variations.  */
 534       if (dim->ts.kind != shift->ts.kind)
 535         gfc_convert_type_warn (dim, &shift->ts, 2, 0);
 536     }
 537
 538   f->value.function.name =
 539     gfc_get_string (PREFIX("eoshift%d_%d%s"), n, shift->ts.kind,
 540                     array->ts.type == BT_CHARACTER ? "_char" : "");
 541 }
 542
 543
 544 void
 545 gfc_resolve_exp (gfc_expr * f, gfc_expr * x)
 546 {
 547   f->ts = x->ts;
 548   f->value.function.name =
 549     gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 550 }
 551
 552
 553 void
 554 gfc_resolve_exponent (gfc_expr * f, gfc_expr * x)
 555 {
 556   f->ts.type = BT_INTEGER;
 557   f->ts.kind = gfc_default_integer_kind;
 558
 559   f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
 560 }
 561
 562
 563 void
 564 gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 565 {
 566   f->ts.type = BT_INTEGER;
 567   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 568     : mpz_get_si (kind->value.integer);
 569
 570   f->value.function.name =
 571     gfc_get_string ("__floor%d_%c%d", f->ts.kind,
 572                     gfc_type_letter (a->ts.type), a->ts.kind);
 573 }
 574
 575
 576 void
 577 gfc_resolve_fnum (gfc_expr * f, gfc_expr * n)
 578 {
 579   f->ts.type = BT_INTEGER;
 580   f->ts.kind = gfc_default_integer_kind;
 581   if (n->ts.kind != f->ts.kind)
 582     gfc_convert_type (n, &f->ts, 2);
 583   f->value.function.name = gfc_get_string (PREFIX("fnum_i%d"), f->ts.kind);
 584 }
 585
 586
 587 void
 588 gfc_resolve_fraction (gfc_expr * f, gfc_expr * x)
 589 {
 590   f->ts = x->ts;
 591   f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
 592 }
 593
 594
 595 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF.  */
 596
 597 void
 598 gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
 599 {
 600   f->ts = x->ts;
 601   f->value.function.name = gfc_get_string ("<intrinsic>");
 602 }
 603
 604
 605 void
 606 gfc_resolve_getcwd (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 607 {
 608   f->ts.type = BT_INTEGER;
 609   f->ts.kind = 4;
 610   f->value.function.name = gfc_get_string (PREFIX("getcwd"));
 611 }
 612
 613
 614 void
 615 gfc_resolve_getgid (gfc_expr * f)
 616 {
 617   f->ts.type = BT_INTEGER;
 618   f->ts.kind = 4;
 619   f->value.function.name = gfc_get_string (PREFIX("getgid"));
 620 }
 621
 622
 623 void
 624 gfc_resolve_getpid (gfc_expr * f)
 625 {
 626   f->ts.type = BT_INTEGER;
 627   f->ts.kind = 4;
 628   f->value.function.name = gfc_get_string (PREFIX("getpid"));
 629 }
 630
 631
 632 void
 633 gfc_resolve_getuid (gfc_expr * f)
 634 {
 635   f->ts.type = BT_INTEGER;
 636   f->ts.kind = 4;
 637   f->value.function.name = gfc_get_string (PREFIX("getuid"));
 638 }
 639
 640 void
 641 gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
 642 {
 643   f->ts.type = BT_INTEGER;
 644   f->ts.kind = 4;
 645   f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
 646 }
 647
 648 void
 649 gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 650 {
 651   /* If the kind of i and j are different, then g77 cross-promoted the
 652      kinds to the largest value.  The Fortran 95 standard requires the
 653      kinds to match.  */
 654   if (i->ts.kind != j->ts.kind)
 655     {
 656       if (i->ts.kind == gfc_kind_max (i,j))
 657         gfc_convert_type(j, &i->ts, 2);
 658       else
 659         gfc_convert_type(i, &j->ts, 2);
 660     }
 661
 662   f->ts = i->ts;
 663   f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
 664 }
 665
 666
 667 void
 668 gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED)
 669 {
 670   f->ts = i->ts;
 671   f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
 672 }
 673
 674
 675 void
 676 gfc_resolve_ibits (gfc_expr * f, gfc_expr * i,
 677                    gfc_expr * pos ATTRIBUTE_UNUSED,
 678                    gfc_expr * len ATTRIBUTE_UNUSED)
 679 {
 680   f->ts = i->ts;
 681   f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
 682 }
 683
 684
 685 void
 686 gfc_resolve_ibset (gfc_expr * f, gfc_expr * i,
 687                    gfc_expr * pos ATTRIBUTE_UNUSED)
 688 {
 689   f->ts = i->ts;
 690   f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
 691 }
 692
 693
 694 void
 695 gfc_resolve_ichar (gfc_expr * f, gfc_expr * c)
 696 {
 697   f->ts.type = BT_INTEGER;
 698   f->ts.kind = gfc_default_integer_kind;
 699
 700   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 701 }
 702
 703
 704 void
 705 gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
 706 {
 707   gfc_resolve_nint (f, a, NULL);
 708 }
 709
 710
 711 void
 712 gfc_resolve_ierrno (gfc_expr * f)
 713 {
 714   f->ts.type = BT_INTEGER;
 715   f->ts.kind = gfc_default_integer_kind;
 716   f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
 717 }
 718
 719
 720 void
 721 gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 722 {
 723   /* If the kind of i and j are different, then g77 cross-promoted the
 724      kinds to the largest value.  The Fortran 95 standard requires the
 725      kinds to match.  */
 726   if (i->ts.kind != j->ts.kind)
 727     {
 728       if (i->ts.kind == gfc_kind_max (i,j))
 729         gfc_convert_type(j, &i->ts, 2);
 730       else
 731         gfc_convert_type(i, &j->ts, 2);
 732     }
 733
 734   f->ts = i->ts;
 735   f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
 736 }
 737
 738
 739 void
 740 gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j)
 741 {
 742   /* If the kind of i and j are different, then g77 cross-promoted the
 743      kinds to the largest value.  The Fortran 95 standard requires the
 744      kinds to match.  */
 745   if (i->ts.kind != j->ts.kind)
 746     {
 747       if (i->ts.kind == gfc_kind_max (i,j))
 748         gfc_convert_type(j, &i->ts, 2);
 749       else
 750         gfc_convert_type(i, &j->ts, 2);
 751     }
 752
 753   f->ts = i->ts;
 754   f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
 755 }
 756
 757
 758 void
 759 gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 760 {
 761   f->ts.type = BT_INTEGER;
 762   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
 763     : mpz_get_si (kind->value.integer);
 764
 765   f->value.function.name =
 766     gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type),
 767                     a->ts.kind);
 768 }
 769
 770
 771 void
 772 gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
 773 {
 774   gfc_typespec ts;
 775
 776   f->ts.type = BT_LOGICAL;
 777   f->ts.kind = gfc_default_integer_kind;
 778   if (u->ts.kind != gfc_c_int_kind)
 779     {
 780       ts.type = BT_INTEGER;
 781       ts.kind = gfc_c_int_kind;
 782       ts.derived = NULL;
 783       ts.cl = NULL;
 784       gfc_convert_type (u, &ts, 2);
 785     }
 786
 787   f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind);
 788 }
 789
 790
 791 void
 792 gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
 793 {
 794   f->ts = i->ts;
 795   f->value.function.name =
 796     gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
 797 }
 798
 799
 800 void
 801 gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
 802                     gfc_expr * size)
 803 {
 804   int s_kind;
 805
 806   s_kind = (size == NULL) ? gfc_default_integer_kind : shift->ts.kind;
 807
 808   f->ts = i->ts;
 809   f->value.function.name =
 810     gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
 811 }
 812
 813
 814 void
 815 gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
 816                   ATTRIBUTE_UNUSED gfc_expr * s)
 817 {
 818   f->ts.type = BT_INTEGER;
 819   f->ts.kind = gfc_default_integer_kind;
 820
 821   f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
 822 }
 823
 824
 825 void
 826 gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
 827                     gfc_expr * dim)
 828 {
 829   static char lbound[] = "__lbound";
 830
 831   f->ts.type = BT_INTEGER;
 832   f->ts.kind = gfc_default_integer_kind;
 833
 834   if (dim == NULL)
 835     {
 836       f->rank = 1;
 837       f->shape = gfc_get_shape (1);
 838       mpz_init_set_ui (f->shape[0], array->rank);
 839     }
 840
 841   f->value.function.name = lbound;
 842 }
 843
 844
 845 void
 846 gfc_resolve_len (gfc_expr * f, gfc_expr * string)
 847 {
 848   f->ts.type = BT_INTEGER;
 849   f->ts.kind = gfc_default_integer_kind;
 850   f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind);
 851 }
 852
 853
 854 void
 855 gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
 856 {
 857   f->ts.type = BT_INTEGER;
 858   f->ts.kind = gfc_default_integer_kind;
 859   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 860 }
 861
 862
 863 void
 864 gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
 865                   gfc_expr * p2 ATTRIBUTE_UNUSED)
 866 {
 867   f->ts.type = BT_INTEGER;
 868   f->ts.kind = gfc_default_integer_kind;
 869   f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
 870 }
 871
 872
 873 void
 874 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
 875 {
 876   f->ts.type= BT_INTEGER;
 877   f->ts.kind = gfc_index_integer_kind;
 878   f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
 879 }
 880
 881
 882 void
 883 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
 884 {
 885   f->ts = x->ts;
 886   f->value.function.name =
 887     gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 888 }
 889
 890
 891 void
 892 gfc_resolve_log10 (gfc_expr * f, gfc_expr * x)
 893 {
 894   f->ts = x->ts;
 895   f->value.function.name =
 896     gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 897 }
 898
 899
 900 void
 901 gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 902 {
 903   f->ts.type = BT_LOGICAL;
 904   f->ts.kind = (kind == NULL) ? gfc_default_logical_kind
 905     : mpz_get_si (kind->value.integer);
 906   f->rank = a->rank;
 907
 908   f->value.function.name =
 909     gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
 910                     gfc_type_letter (a->ts.type), a->ts.kind);
 911 }
 912
 913
 914 void
 915 gfc_resolve_malloc (gfc_expr * f, gfc_expr * size)
 916 {
 917   if (size->ts.kind < gfc_index_integer_kind)
 918     {
 919       gfc_typespec ts;
 920
 921       ts.type = BT_INTEGER;
 922       ts.kind = gfc_index_integer_kind;
 923       gfc_convert_type_warn (size, &ts, 2, 0);
 924     }
 925
 926   f->ts.type = BT_INTEGER;
 927   f->ts.kind = gfc_index_integer_kind;
 928   f->value.function.name = gfc_get_string (PREFIX("malloc"));
 929 }
 930
 931
 932 void
 933 gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 934 {
 935   gfc_expr temp;
 936
 937   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 938     {
 939       f->ts.type = BT_LOGICAL;
 940       f->ts.kind = gfc_default_logical_kind;
 941     }
 942   else
 943     {
 944       temp.expr_type = EXPR_OP;
 945       gfc_clear_ts (&temp.ts);
 946       temp.value.op.operator = INTRINSIC_NONE;
 947       temp.value.op.op1 = a;
 948       temp.value.op.op2 = b;
 949       gfc_type_convert_binary (&temp);
 950       f->ts = temp.ts;
 951     }
 952
 953   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
 954
 955   f->value.function.name =
 956     gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
 957                     f->ts.kind);
 958 }
 959
 960
 961 static void
 962 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
 963 {
 964   gfc_actual_arglist *a;
 965
 966   f->ts.type = args->expr->ts.type;
 967   f->ts.kind = args->expr->ts.kind;
 968   /* Find the largest type kind.  */
 969   for (a = args->next; a; a = a->next)
 970     {
 971       if (a->expr->ts.kind > f->ts.kind)
 972         f->ts.kind = a->expr->ts.kind;
 973     }
 974
 975   /* Convert all parameters to the required kind.  */
 976   for (a = args; a; a = a->next)
 977     {
 978       if (a->expr->ts.kind != f->ts.kind)
 979         gfc_convert_type (a->expr, &f->ts, 2);
 980     }
 981
 982   f->value.function.name =
 983     gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
 984 }
 985
 986
 987 void
 988 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
 989 {
 990   gfc_resolve_minmax ("__max_%c%d", f, args);
 991 }
 992
 993
 994 void
 995 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 996                     gfc_expr * mask)
 997 {
 998   const char *name;
 999
1000   f->ts.type = BT_INTEGER;
1001   f->ts.kind = gfc_default_integer_kind;
1002
1003   if (dim == NULL)
1004     f->rank = 1;
1005   else
1006     {
1007       f->rank = array->rank - 1;
1008       gfc_resolve_dim_arg (dim);
1009     }
1010
1011   name = mask ? "mmaxloc" : "maxloc";
1012   f->value.function.name =
1013     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1014                     gfc_type_letter (array->ts.type), array->ts.kind);
1015 }
1016
1017
1018 void
1019 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1020                     gfc_expr * mask)
1021 {
1022   f->ts = array->ts;
1023
1024   if (dim != NULL)
1025     {
1026       f->rank = array->rank - 1;
1027       gfc_resolve_dim_arg (dim);
1028     }
1029
1030   f->value.function.name =
1031     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
1032                     gfc_type_letter (array->ts.type), array->ts.kind);
1033 }
1034
1035
1036 void
1037 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
1038                    gfc_expr * fsource ATTRIBUTE_UNUSED,
1039                    gfc_expr * mask ATTRIBUTE_UNUSED)
1040 {
1041   if (tsource->ts.type == BT_CHARACTER)
1042     check_charlen_present (tsource);
1043
1044   f->ts = tsource->ts;
1045   f->value.function.name =
1046     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1047                     tsource->ts.kind);
1048 }
1049
1050
1051 void
1052 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
1053 {
1054   gfc_resolve_minmax ("__min_%c%d", f, args);
1055 }
1056
1057
1058 void
1059 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1060                     gfc_expr * mask)
1061 {
1062   const char *name;
1063
1064   f->ts.type = BT_INTEGER;
1065   f->ts.kind = gfc_default_integer_kind;
1066
1067   if (dim == NULL)
1068     f->rank = 1;
1069   else
1070     {
1071       f->rank = array->rank - 1;
1072       gfc_resolve_dim_arg (dim);
1073     }
1074
1075   name = mask ? "mminloc" : "minloc";
1076   f->value.function.name =
1077     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1078                     gfc_type_letter (array->ts.type), array->ts.kind);
1079 }
1080
1081
1082 void
1083 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1084                     gfc_expr * mask)
1085 {
1086   f->ts = array->ts;
1087
1088   if (dim != NULL)
1089     {
1090       f->rank = array->rank - 1;
1091       gfc_resolve_dim_arg (dim);
1092     }
1093
1094   f->value.function.name =
1095     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1096                     gfc_type_letter (array->ts.type), array->ts.kind);
1097 }
1098
1099
1100 void
1101 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
1102                  gfc_expr * p ATTRIBUTE_UNUSED)
1103 {
1104   f->ts = a->ts;
1105   f->value.function.name =
1106     gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1107 }
1108
1109
1110 void
1111 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
1112                     gfc_expr * p ATTRIBUTE_UNUSED)
1113 {
1114   f->ts = a->ts;
1115   f->value.function.name =
1116     gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
1117                     a->ts.kind);
1118 }
1119
1120 void
1121 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1122 {
1123   f->ts = a->ts;
1124   f->value.function.name =
1125     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1126             a->ts.kind);
1127 }
1128
1129 void
1130 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1131 {
1132   f->ts.type = BT_INTEGER;
1133   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1134     : mpz_get_si (kind->value.integer);
1135
1136   f->value.function.name =
1137     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1138 }
1139
1140
1141 void
1142 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1143 {
1144   f->ts = i->ts;
1145   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1146 }
1147
1148
1149 void
1150 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1151                   gfc_expr * vector ATTRIBUTE_UNUSED)
1152 {
1153   f->ts = array->ts;
1154   f->rank = 1;
1155
1156   if (mask->rank != 0)
1157     f->value.function.name = (array->ts.type == BT_CHARACTER
1158                               ? PREFIX("pack_char")
1159                               : PREFIX("pack"));
1160   else
1161     {
1162       /* We convert mask to default logical only in the scalar case.
1163          In the array case we can simply read the array as if it were
1164          of type default logical.  */
1165       if (mask->ts.kind != gfc_default_logical_kind)
1166         {
1167           gfc_typespec ts;
1168
1169           ts.type = BT_LOGICAL;
1170           ts.kind = gfc_default_logical_kind;
1171           gfc_convert_type (mask, &ts, 2);
1172         }
1173
1174       f->value.function.name = (array->ts.type == BT_CHARACTER
1175                                 ? PREFIX("pack_s_char")
1176                                 : PREFIX("pack_s"));
1177     }
1178 }
1179
1180
1181 void
1182 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1183                      gfc_expr * mask)
1184 {
1185   f->ts = array->ts;
1186
1187   if (dim != NULL)
1188     {
1189       f->rank = array->rank - 1;
1190       gfc_resolve_dim_arg (dim);
1191     }
1192
1193   f->value.function.name =
1194     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1195                     gfc_type_letter (array->ts.type), array->ts.kind);
1196 }
1197
1198
1199 void
1200 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1201 {
1202   f->ts.type = BT_REAL;
1203
1204   if (kind != NULL)
1205     f->ts.kind = mpz_get_si (kind->value.integer);
1206   else
1207     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1208       a->ts.kind : gfc_default_real_kind;
1209
1210   f->value.function.name =
1211     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1212                     gfc_type_letter (a->ts.type), a->ts.kind);
1213 }
1214
1215
1216 void
1217 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1218 {
1219   f->ts.type = BT_REAL;
1220   f->ts.kind = a->ts.kind;
1221   f->value.function.name =
1222     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1223                     gfc_type_letter (a->ts.type), a->ts.kind);
1224 }
1225
1226
1227 void
1228 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1229                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1230 {
1231   f->ts.type = BT_INTEGER;
1232   f->ts.kind = gfc_default_integer_kind;
1233   f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1234 }
1235
1236
1237 void
1238 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1239                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1240 {
1241   f->ts.type = BT_CHARACTER;
1242   f->ts.kind = string->ts.kind;
1243   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1244 }
1245
1246
1247 void
1248 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1249                      gfc_expr * pad ATTRIBUTE_UNUSED,
1250                      gfc_expr * order ATTRIBUTE_UNUSED)
1251 {
1252   mpz_t rank;
1253   int kind;
1254   int i;
1255
1256   f->ts = source->ts;
1257
1258   gfc_array_size (shape, &rank);
1259   f->rank = mpz_get_si (rank);
1260   mpz_clear (rank);
1261   switch (source->ts.type)
1262     {
1263     case BT_COMPLEX:
1264       kind = source->ts.kind * 2;
1265       break;
1266
1267     case BT_REAL:
1268     case BT_INTEGER:
1269     case BT_LOGICAL:
1270       kind = source->ts.kind;
1271       break;
1272
1273     default:
1274       kind = 0;
1275       break;
1276     }
1277
1278   switch (kind)
1279     {
1280     case 4:
1281     case 8:
1282     case 10:
1283     case 16:
1284       if (source->ts.type == BT_COMPLEX)
1285         f->value.function.name =
1286           gfc_get_string (PREFIX("reshape_%c%d"),
1287                           gfc_type_letter (BT_COMPLEX), source->ts.kind);
1288       else
1289         f->value.function.name =
1290           gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1291
1292       break;
1293
1294     default:
1295       f->value.function.name = (source->ts.type == BT_CHARACTER
1296                                 ? PREFIX("reshape_char")
1297                                 : PREFIX("reshape"));
1298       break;
1299     }
1300
1301   /* TODO: Make this work with a constant ORDER parameter.  */
1302   if (shape->expr_type == EXPR_ARRAY
1303       && gfc_is_constant_expr (shape)
1304       && order == NULL)
1305     {
1306       gfc_constructor *c;
1307       f->shape = gfc_get_shape (f->rank);
1308       c = shape->value.constructor;
1309       for (i = 0; i < f->rank; i++)
1310         {
1311           mpz_init_set (f->shape[i], c->expr->value.integer);
1312           c = c->next;
1313         }
1314     }
1315
1316   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1317      so many runtime variations.  */
1318   if (shape->ts.kind != gfc_index_integer_kind)
1319     {
1320       gfc_typespec ts = shape->ts;
1321       ts.kind = gfc_index_integer_kind;
1322       gfc_convert_type_warn (shape, &ts, 2, 0);
1323     }
1324   if (order && order->ts.kind != gfc_index_integer_kind)
1325     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1326 }
1327
1328
1329 void
1330 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1331 {
1332   f->ts = x->ts;
1333   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1334 }
1335
1336
1337 void
1338 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1339 {
1340   f->ts = x->ts;
1341
1342   /* The implementation calls scalbn which takes an int as the
1343      second argument.  */
1344   if (i->ts.kind != gfc_c_int_kind)
1345     {
1346       gfc_typespec ts;
1347
1348       ts.type = BT_INTEGER;
1349       ts.kind = gfc_default_integer_kind;
1350
1351       gfc_convert_type_warn (i, &ts, 2, 0);
1352     }
1353
1354   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1355 }
1356
1357
1358 void
1359 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1360                   gfc_expr * set ATTRIBUTE_UNUSED,
1361                   gfc_expr * back ATTRIBUTE_UNUSED)
1362 {
1363   f->ts.type = BT_INTEGER;
1364   f->ts.kind = gfc_default_integer_kind;
1365   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1366 }
1367
1368
1369 void
1370 gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0)
1371 {
1372   t1->ts = t0->ts;
1373   t1->value.function.name =
1374     gfc_get_string (PREFIX("secnds"));
1375 }
1376
1377
1378 void
1379 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1380 {
1381   f->ts = x->ts;
1382
1383   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1384      convert type so we don't have to implement all possible
1385      permutations.  */
1386   if (i->ts.kind != 4)
1387     {
1388       gfc_typespec ts;
1389
1390       ts.type = BT_INTEGER;
1391       ts.kind = gfc_default_integer_kind;
1392
1393       gfc_convert_type_warn (i, &ts, 2, 0);
1394     }
1395
1396   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1397 }
1398
1399
1400 void
1401 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1402 {
1403   f->ts.type = BT_INTEGER;
1404   f->ts.kind = gfc_default_integer_kind;
1405   f->rank = 1;
1406   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1407   f->shape = gfc_get_shape (1);
1408   mpz_init_set_ui (f->shape[0], array->rank);
1409 }
1410
1411
1412 void
1413 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1414 {
1415   f->ts = a->ts;
1416   f->value.function.name =
1417     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1418 }
1419
1420
1421 void
1422 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1423 {
1424   f->ts.type = BT_INTEGER;
1425   f->ts.kind = gfc_c_int_kind;
1426
1427   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
1428   if (handler->ts.type == BT_INTEGER)
1429     {
1430       if (handler->ts.kind != gfc_c_int_kind)
1431         gfc_convert_type (handler, &f->ts, 2);
1432       f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1433     }
1434   else
1435     f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1436
1437   if (number->ts.kind != gfc_c_int_kind)
1438     gfc_convert_type (number, &f->ts, 2);
1439 }
1440
1441
1442 void
1443 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1444 {
1445   f->ts = x->ts;
1446   f->value.function.name =
1447     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1448 }
1449
1450
1451 void
1452 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1453 {
1454   f->ts = x->ts;
1455   f->value.function.name =
1456     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1457 }
1458
1459
1460 void
1461 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1462 {
1463   f->ts = x->ts;
1464   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1465 }
1466
1467
1468 void
1469 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1470                     gfc_expr * dim,
1471                     gfc_expr * ncopies)
1472 {
1473   if (source->ts.type == BT_CHARACTER)
1474     check_charlen_present (source);
1475
1476   f->ts = source->ts;
1477   f->rank = source->rank + 1;
1478   if (source->rank == 0)
1479     f->value.function.name = (source->ts.type == BT_CHARACTER
1480                               ? PREFIX("spread_char_scalar")
1481                               : PREFIX("spread_scalar"));
1482   else
1483     f->value.function.name = (source->ts.type == BT_CHARACTER
1484                               ? PREFIX("spread_char")
1485                               : PREFIX("spread"));
1486
1487   gfc_resolve_dim_arg (dim);
1488   gfc_resolve_index (ncopies, 1);
1489 }
1490
1491
1492 void
1493 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1494 {
1495   f->ts = x->ts;
1496   f->value.function.name =
1497     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1498 }
1499
1500
1501 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1502
1503 void
1504 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1505                   gfc_expr * a ATTRIBUTE_UNUSED)
1506 {
1507   f->ts.type = BT_INTEGER;
1508   f->ts.kind = gfc_default_integer_kind;
1509   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1510 }
1511
1512
1513 void
1514 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1515 {
1516   f->ts.type = BT_INTEGER;
1517   f->ts.kind = gfc_default_integer_kind;
1518   if (n->ts.kind != f->ts.kind)
1519     gfc_convert_type (n, &f->ts, 2);
1520
1521   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1522 }
1523
1524
1525 void
1526 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1527                  gfc_expr * mask)
1528 {
1529   f->ts = array->ts;
1530
1531   if (dim != NULL)
1532     {
1533       f->rank = array->rank - 1;
1534       gfc_resolve_dim_arg (dim);
1535     }
1536
1537   f->value.function.name =
1538     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1539                     gfc_type_letter (array->ts.type), array->ts.kind);
1540 }
1541
1542
1543 void
1544 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1545                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1546 {
1547   f->ts.type = BT_INTEGER;
1548   f->ts.kind = gfc_default_integer_kind;
1549   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1550 }
1551
1552
1553 /* Resolve the g77 compatibility function SYSTEM.  */
1554
1555 void
1556 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1557 {
1558   f->ts.type = BT_INTEGER;
1559   f->ts.kind = 4;
1560   f->value.function.name = gfc_get_string (PREFIX("system"));
1561 }
1562
1563
1564 void
1565 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1566 {
1567   f->ts = x->ts;
1568   f->value.function.name =
1569     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1570 }
1571
1572
1573 void
1574 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1575 {
1576   f->ts = x->ts;
1577   f->value.function.name =
1578     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1579 }
1580
1581
1582 void
1583 gfc_resolve_time (gfc_expr * f)
1584 {
1585   f->ts.type = BT_INTEGER;
1586   f->ts.kind = 4;
1587   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1588 }
1589
1590
1591 void
1592 gfc_resolve_time8 (gfc_expr * f)
1593 {
1594   f->ts.type = BT_INTEGER;
1595   f->ts.kind = 8;
1596   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1597 }
1598
1599
1600 void
1601 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1602                       gfc_expr * mold, gfc_expr * size)
1603 {
1604   /* TODO: Make this do something meaningful.  */
1605   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1606
1607   f->ts = mold->ts;
1608
1609   if (size == NULL && mold->rank == 0)
1610     {
1611       f->rank = 0;
1612       f->value.function.name = transfer0;
1613     }
1614   else
1615     {
1616       f->rank = 1;
1617       f->value.function.name = transfer1;
1618     }
1619 }
1620
1621
1622 void
1623 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1624 {
1625   int kind;
1626
1627   f->ts = matrix->ts;
1628   f->rank = 2;
1629   if (matrix->shape)
1630     {
1631       f->shape = gfc_get_shape (2);
1632       mpz_init_set (f->shape[0], matrix->shape[1]);
1633       mpz_init_set (f->shape[1], matrix->shape[0]);
1634     }
1635
1636   kind = matrix->ts.kind;
1637
1638   switch (kind)
1639     {
1640     case 4:
1641     case 8:
1642     case 10:
1643     case 16:
1644       switch (matrix->ts.type)
1645         {
1646         case BT_COMPLEX:
1647           f->value.function.name =
1648             gfc_get_string (PREFIX("transpose_c%d"), kind);
1649           break;
1650
1651         case BT_INTEGER:
1652         case BT_REAL:
1653         case BT_LOGICAL:
1654           /* Use the integer routines for real and logical cases.  This
1655              assumes they all have the same alignment requirements.  */
1656           f->value.function.name =
1657             gfc_get_string (PREFIX("transpose_i%d"), kind);
1658           break;
1659
1660         default:
1661           f->value.function.name = PREFIX("transpose");
1662           break;
1663         }
1664       break;
1665
1666     default:
1667       f->value.function.name = (matrix->ts.type == BT_CHARACTER
1668                                 ? PREFIX("transpose_char")
1669                                 : PREFIX("transpose"));
1670       break;
1671     }
1672 }
1673
1674
1675 void
1676 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1677 {
1678   f->ts.type = BT_CHARACTER;
1679   f->ts.kind = string->ts.kind;
1680   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1681 }
1682
1683
1684 void
1685 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1686                     gfc_expr * dim)
1687 {
1688   static char ubound[] = "__ubound";
1689
1690   f->ts.type = BT_INTEGER;
1691   f->ts.kind = gfc_default_integer_kind;
1692
1693   if (dim == NULL)
1694     {
1695       f->rank = 1;
1696       f->shape = gfc_get_shape (1);
1697       mpz_init_set_ui (f->shape[0], array->rank);
1698     }
1699
1700   f->value.function.name = ubound;
1701 }
1702
1703
1704 /* Resolve the g77 compatibility function UMASK.  */
1705
1706 void
1707 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1708 {
1709   f->ts.type = BT_INTEGER;
1710   f->ts.kind = n->ts.kind;
1711   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1712 }
1713
1714
1715 /* Resolve the g77 compatibility function UNLINK.  */
1716
1717 void
1718 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1719 {
1720   f->ts.type = BT_INTEGER;
1721   f->ts.kind = 4;
1722   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1723 }
1724
1725 void
1726 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1727                     gfc_expr * field ATTRIBUTE_UNUSED)
1728 {
1729   f->ts = vector->ts;
1730   f->rank = mask->rank;
1731
1732   f->value.function.name =
1733     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1734                     vector->ts.type == BT_CHARACTER ? "_char" : "");
1735 }
1736
1737
1738 void
1739 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1740                     gfc_expr * set ATTRIBUTE_UNUSED,
1741                     gfc_expr * back ATTRIBUTE_UNUSED)
1742 {
1743   f->ts.type = BT_INTEGER;
1744   f->ts.kind = gfc_default_integer_kind;
1745   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1746 }
1747
1748
1749 /* Intrinsic subroutine resolution.  */
1750
1751 void
1752 gfc_resolve_alarm_sub (gfc_code * c)
1753 {
1754   const char *name;
1755   gfc_expr *seconds, *handler, *status;
1756   gfc_typespec ts;
1757
1758   seconds = c->ext.actual->expr;
1759   handler = c->ext.actual->next->expr;
1760   status = c->ext.actual->next->next->expr;
1761   ts.type = BT_INTEGER;
1762   ts.kind = gfc_c_int_kind;
1763
1764   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
1765   if (handler->ts.type == BT_INTEGER)
1766     {
1767       if (handler->ts.kind != gfc_c_int_kind)
1768         gfc_convert_type (handler, &ts, 2);
1769       name = gfc_get_string (PREFIX("alarm_sub_int"));
1770     }
1771   else
1772     name = gfc_get_string (PREFIX("alarm_sub"));
1773
1774   if (seconds->ts.kind != gfc_c_int_kind)
1775     gfc_convert_type (seconds, &ts, 2);
1776   if (status != NULL && status->ts.kind != gfc_c_int_kind)
1777     gfc_convert_type (status, &ts, 2);
1778
1779   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1780 }
1781
1782 void
1783 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1784 {
1785   const char *name;
1786
1787   name = gfc_get_string (PREFIX("cpu_time_%d"),
1788                          c->ext.actual->expr->ts.kind);
1789   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1790 }
1791
1792
1793 void
1794 gfc_resolve_mvbits (gfc_code * c)
1795 {
1796   const char *name;
1797   int kind;
1798
1799   kind = c->ext.actual->expr->ts.kind;
1800   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1801
1802   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1803 }
1804
1805
1806 void
1807 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1808 {
1809   const char *name;
1810   int kind;
1811
1812   kind = c->ext.actual->expr->ts.kind;
1813   if (c->ext.actual->expr->rank == 0)
1814     name = gfc_get_string (PREFIX("random_r%d"), kind);
1815   else
1816     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1817
1818   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1819 }
1820
1821
1822 void
1823 gfc_resolve_rename_sub (gfc_code * c)
1824 {
1825   const char *name;
1826   int kind;
1827
1828   if (c->ext.actual->next->next->expr != NULL)
1829     kind = c->ext.actual->next->next->expr->ts.kind;
1830   else
1831     kind = gfc_default_integer_kind;
1832
1833   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1834   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1835 }
1836
1837
1838 void
1839 gfc_resolve_kill_sub (gfc_code * c)
1840 {
1841   const char *name;
1842   int kind;
1843
1844   if (c->ext.actual->next->next->expr != NULL)
1845     kind = c->ext.actual->next->next->expr->ts.kind;
1846   else
1847     kind = gfc_default_integer_kind;
1848
1849   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1850   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1851 }
1852
1853
1854 void
1855 gfc_resolve_link_sub (gfc_code * c)
1856 {
1857   const char *name;
1858   int kind;
1859
1860   if (c->ext.actual->next->next->expr != NULL)
1861     kind = c->ext.actual->next->next->expr->ts.kind;
1862   else
1863     kind = gfc_default_integer_kind;
1864
1865   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1866   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1867 }
1868
1869
1870 void
1871 gfc_resolve_symlnk_sub (gfc_code * c)
1872 {
1873   const char *name;
1874   int kind;
1875
1876   if (c->ext.actual->next->next->expr != NULL)
1877     kind = c->ext.actual->next->next->expr->ts.kind;
1878   else
1879     kind = gfc_default_integer_kind;
1880
1881   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1882   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1883 }
1884
1885
1886 /* G77 compatibility subroutines etime() and dtime().  */
1887
1888 void
1889 gfc_resolve_etime_sub (gfc_code * c)
1890 {
1891   const char *name;
1892
1893   name = gfc_get_string (PREFIX("etime_sub"));
1894   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1895 }
1896
1897
1898 /* G77 compatibility subroutine second().  */
1899
1900 void
1901 gfc_resolve_second_sub (gfc_code * c)
1902 {
1903   const char *name;
1904
1905   name = gfc_get_string (PREFIX("second_sub"));
1906   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1907 }
1908
1909
1910 void
1911 gfc_resolve_sleep_sub (gfc_code * c)
1912 {
1913   const char *name;
1914   int kind;
1915
1916   if (c->ext.actual->expr != NULL)
1917     kind = c->ext.actual->expr->ts.kind;
1918   else
1919     kind = gfc_default_integer_kind;
1920
1921   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1922   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1923 }
1924
1925
1926 /* G77 compatibility function srand().  */
1927
1928 void
1929 gfc_resolve_srand (gfc_code * c)
1930 {
1931   const char *name;
1932   name = gfc_get_string (PREFIX("srand"));
1933   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1934 }
1935
1936
1937 /* Resolve the getarg intrinsic subroutine.  */
1938
1939 void
1940 gfc_resolve_getarg (gfc_code * c)
1941 {
1942   const char *name;
1943   int kind;
1944
1945   kind = gfc_default_integer_kind;
1946   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1947   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1948 }
1949
1950 /* Resolve the getcwd intrinsic subroutine.  */
1951
1952 void
1953 gfc_resolve_getcwd_sub (gfc_code * c)
1954 {
1955   const char *name;
1956   int kind;
1957
1958   if (c->ext.actual->next->expr != NULL)
1959     kind = c->ext.actual->next->expr->ts.kind;
1960   else
1961     kind = gfc_default_integer_kind;
1962
1963   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1964   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1965 }
1966
1967
1968 /* Resolve the get_command intrinsic subroutine.  */
1969
1970 void
1971 gfc_resolve_get_command (gfc_code * c)
1972 {
1973   const char *name;
1974   int kind;
1975
1976   kind = gfc_default_integer_kind;
1977   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1978   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1979 }
1980
1981
1982 /* Resolve the get_command_argument intrinsic subroutine.  */
1983
1984 void
1985 gfc_resolve_get_command_argument (gfc_code * c)
1986 {
1987   const char *name;
1988   int kind;
1989
1990   kind = gfc_default_integer_kind;
1991   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1992   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1993 }
1994
1995 /* Resolve the get_environment_variable intrinsic subroutine.  */
1996
1997 void
1998 gfc_resolve_get_environment_variable (gfc_code * code)
1999 {
2000   const char *name;
2001   int kind;
2002
2003   kind = gfc_default_integer_kind;
2004   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
2005   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2006 }
2007
2008 void
2009 gfc_resolve_signal_sub (gfc_code * c)
2010 {
2011   const char *name;
2012   gfc_expr *number, *handler, *status;
2013   gfc_typespec ts;
2014
2015   number = c->ext.actual->expr;
2016   handler = c->ext.actual->next->expr;
2017   status = c->ext.actual->next->next->expr;
2018   ts.type = BT_INTEGER;
2019   ts.kind = gfc_c_int_kind;
2020
2021   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2022   if (handler->ts.type == BT_INTEGER)
2023     {
2024       if (handler->ts.kind != gfc_c_int_kind)
2025         gfc_convert_type (handler, &ts, 2);
2026       name = gfc_get_string (PREFIX("signal_sub_int"));
2027     }
2028   else
2029     name = gfc_get_string (PREFIX("signal_sub"));
2030
2031   if (number->ts.kind != gfc_c_int_kind)
2032     gfc_convert_type (number, &ts, 2);
2033   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2034     gfc_convert_type (status, &ts, 2);
2035
2036   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2037 }
2038
2039 /* Resolve the SYSTEM intrinsic subroutine.  */
2040
2041 void
2042 gfc_resolve_system_sub (gfc_code * c)
2043 {
2044   const char *name;
2045
2046   name = gfc_get_string (PREFIX("system_sub"));
2047   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2048 }
2049
2050 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2051
2052 void
2053 gfc_resolve_system_clock (gfc_code * c)
2054 {
2055   const char *name;
2056   int kind;
2057
2058   if (c->ext.actual->expr != NULL)
2059     kind = c->ext.actual->expr->ts.kind;
2060   else if (c->ext.actual->next->expr != NULL)
2061       kind = c->ext.actual->next->expr->ts.kind;
2062   else if (c->ext.actual->next->next->expr != NULL)
2063       kind = c->ext.actual->next->next->expr->ts.kind;
2064   else
2065     kind = gfc_default_integer_kind;
2066
2067   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2068   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2069 }
2070
2071 /* Resolve the EXIT intrinsic subroutine.  */
2072
2073 void
2074 gfc_resolve_exit (gfc_code * c)
2075 {
2076   const char *name;
2077   int kind;
2078
2079   if (c->ext.actual->expr != NULL)
2080     kind = c->ext.actual->expr->ts.kind;
2081   else
2082     kind = gfc_default_integer_kind;
2083
2084   name = gfc_get_string (PREFIX("exit_i%d"), kind);
2085   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2086 }
2087
2088 /* Resolve the FLUSH intrinsic subroutine.  */
2089
2090 void
2091 gfc_resolve_flush (gfc_code * c)
2092 {
2093   const char *name;
2094   gfc_typespec ts;
2095   gfc_expr *n;
2096
2097   ts.type = BT_INTEGER;
2098   ts.kind = gfc_default_integer_kind;
2099   n = c->ext.actual->expr;
2100   if (n != NULL
2101       && n->ts.kind != ts.kind)
2102     gfc_convert_type (n, &ts, 2);
2103
2104   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2105   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2106 }
2107
2108
2109 void
2110 gfc_resolve_free (gfc_code * c)
2111 {
2112   gfc_typespec ts;
2113   gfc_expr *n;
2114
2115   ts.type = BT_INTEGER;
2116   ts.kind = gfc_index_integer_kind;
2117   n = c->ext.actual->expr;
2118   if (n->ts.kind != ts.kind)
2119     gfc_convert_type (n, &ts, 2);
2120
2121   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2122 }
2123
2124
2125 void
2126 gfc_resolve_gerror (gfc_code * c)
2127 {
2128   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2129 }
2130
2131
2132 void
2133 gfc_resolve_getlog (gfc_code * c)
2134 {
2135   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2136 }
2137
2138
2139 void
2140 gfc_resolve_hostnm_sub (gfc_code * c)
2141 {
2142   const char *name;
2143   int kind;
2144
2145   if (c->ext.actual->next->expr != NULL)
2146     kind = c->ext.actual->next->expr->ts.kind;
2147   else
2148     kind = gfc_default_integer_kind;
2149
2150   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2151   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2152 }
2153
2154
2155 void
2156 gfc_resolve_perror (gfc_code * c)
2157 {
2158   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2159 }
2160
2161 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2162
2163 void
2164 gfc_resolve_stat_sub (gfc_code * c)
2165 {
2166   const char *name;
2167
2168   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2169   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2170 }
2171
2172
2173 void
2174 gfc_resolve_fstat_sub (gfc_code * c)
2175 {
2176   const char *name;
2177   gfc_expr *u;
2178   gfc_typespec *ts;
2179
2180   u = c->ext.actual->expr;
2181   ts = &c->ext.actual->next->expr->ts;
2182   if (u->ts.kind != ts->kind)
2183     gfc_convert_type (u, ts, 2);
2184   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2185   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2186 }
2187
2188
2189 void
2190 gfc_resolve_ttynam_sub (gfc_code * c)
2191 {
2192   gfc_typespec ts;
2193
2194   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2195     {
2196       ts.type = BT_INTEGER;
2197       ts.kind = gfc_c_int_kind;
2198       ts.derived = NULL;
2199       ts.cl = NULL;
2200       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2201     }
2202
2203   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2204 }
2205
2206
2207 /* Resolve the UMASK intrinsic subroutine.  */
2208
2209 void
2210 gfc_resolve_umask_sub (gfc_code * c)
2211 {
2212   const char *name;
2213   int kind;
2214
2215   if (c->ext.actual->next->expr != NULL)
2216     kind = c->ext.actual->next->expr->ts.kind;
2217   else
2218     kind = gfc_default_integer_kind;
2219
2220   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2221   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2222 }
2223
2224 /* Resolve the UNLINK intrinsic subroutine.  */
2225
2226 void
2227 gfc_resolve_unlink_sub (gfc_code * c)
2228 {
2229   const char *name;
2230   int kind;
2231
2232   if (c->ext.actual->next->expr != NULL)
2233     kind = c->ext.actual->next->expr->ts.kind;
2234   else
2235     kind = gfc_default_integer_kind;
2236
2237   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2238   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2239 }