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_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1371 {
1372   f->ts = x->ts;
1373
1374   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1375      convert type so we don't have to implement all possible
1376      permutations.  */
1377   if (i->ts.kind != 4)
1378     {
1379       gfc_typespec ts;
1380
1381       ts.type = BT_INTEGER;
1382       ts.kind = gfc_default_integer_kind;
1383
1384       gfc_convert_type_warn (i, &ts, 2, 0);
1385     }
1386
1387   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1388 }
1389
1390
1391 void
1392 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1393 {
1394   f->ts.type = BT_INTEGER;
1395   f->ts.kind = gfc_default_integer_kind;
1396   f->rank = 1;
1397   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1398   f->shape = gfc_get_shape (1);
1399   mpz_init_set_ui (f->shape[0], array->rank);
1400 }
1401
1402
1403 void
1404 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1405 {
1406   f->ts = a->ts;
1407   f->value.function.name =
1408     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1409 }
1410
1411
1412 void
1413 gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler)
1414 {
1415   f->ts.type = BT_INTEGER;
1416   f->ts.kind = gfc_c_int_kind;
1417
1418   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
1419   if (handler->ts.type == BT_INTEGER)
1420     {
1421       if (handler->ts.kind != gfc_c_int_kind)
1422         gfc_convert_type (handler, &f->ts, 2);
1423       f->value.function.name = gfc_get_string (PREFIX("signal_func_int"));
1424     }
1425   else
1426     f->value.function.name = gfc_get_string (PREFIX("signal_func"));
1427
1428   if (number->ts.kind != gfc_c_int_kind)
1429     gfc_convert_type (number, &f->ts, 2);
1430 }
1431
1432
1433 void
1434 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1435 {
1436   f->ts = x->ts;
1437   f->value.function.name =
1438     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1439 }
1440
1441
1442 void
1443 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1444 {
1445   f->ts = x->ts;
1446   f->value.function.name =
1447     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1448 }
1449
1450
1451 void
1452 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1453 {
1454   f->ts = x->ts;
1455   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1456 }
1457
1458
1459 void
1460 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1461                     gfc_expr * dim,
1462                     gfc_expr * ncopies)
1463 {
1464   if (source->ts.type == BT_CHARACTER)
1465     check_charlen_present (source);
1466
1467   f->ts = source->ts;
1468   f->rank = source->rank + 1;
1469   if (source->rank == 0)
1470     f->value.function.name = (source->ts.type == BT_CHARACTER
1471                               ? PREFIX("spread_char_scalar")
1472                               : PREFIX("spread_scalar"));
1473   else
1474     f->value.function.name = (source->ts.type == BT_CHARACTER
1475                               ? PREFIX("spread_char")
1476                               : PREFIX("spread"));
1477
1478   gfc_resolve_dim_arg (dim);
1479   gfc_resolve_index (ncopies, 1);
1480 }
1481
1482
1483 void
1484 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1485 {
1486   f->ts = x->ts;
1487   f->value.function.name =
1488     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1489 }
1490
1491
1492 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1493
1494 void
1495 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1496                   gfc_expr * a ATTRIBUTE_UNUSED)
1497 {
1498   f->ts.type = BT_INTEGER;
1499   f->ts.kind = gfc_default_integer_kind;
1500   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1501 }
1502
1503
1504 void
1505 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1506 {
1507   f->ts.type = BT_INTEGER;
1508   f->ts.kind = gfc_default_integer_kind;
1509   if (n->ts.kind != f->ts.kind)
1510     gfc_convert_type (n, &f->ts, 2);
1511
1512   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1513 }
1514
1515
1516 void
1517 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1518                  gfc_expr * mask)
1519 {
1520   f->ts = array->ts;
1521
1522   if (dim != NULL)
1523     {
1524       f->rank = array->rank - 1;
1525       gfc_resolve_dim_arg (dim);
1526     }
1527
1528   f->value.function.name =
1529     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1530                     gfc_type_letter (array->ts.type), array->ts.kind);
1531 }
1532
1533
1534 void
1535 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1536                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1537 {
1538   f->ts.type = BT_INTEGER;
1539   f->ts.kind = gfc_default_integer_kind;
1540   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1541 }
1542
1543
1544 /* Resolve the g77 compatibility function SYSTEM.  */
1545
1546 void
1547 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1548 {
1549   f->ts.type = BT_INTEGER;
1550   f->ts.kind = 4;
1551   f->value.function.name = gfc_get_string (PREFIX("system"));
1552 }
1553
1554
1555 void
1556 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1557 {
1558   f->ts = x->ts;
1559   f->value.function.name =
1560     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1561 }
1562
1563
1564 void
1565 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1566 {
1567   f->ts = x->ts;
1568   f->value.function.name =
1569     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1570 }
1571
1572
1573 void
1574 gfc_resolve_time (gfc_expr * f)
1575 {
1576   f->ts.type = BT_INTEGER;
1577   f->ts.kind = 4;
1578   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1579 }
1580
1581
1582 void
1583 gfc_resolve_time8 (gfc_expr * f)
1584 {
1585   f->ts.type = BT_INTEGER;
1586   f->ts.kind = 8;
1587   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1588 }
1589
1590
1591 void
1592 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1593                       gfc_expr * mold, gfc_expr * size)
1594 {
1595   /* TODO: Make this do something meaningful.  */
1596   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1597
1598   f->ts = mold->ts;
1599
1600   if (size == NULL && mold->rank == 0)
1601     {
1602       f->rank = 0;
1603       f->value.function.name = transfer0;
1604     }
1605   else
1606     {
1607       f->rank = 1;
1608       f->value.function.name = transfer1;
1609     }
1610 }
1611
1612
1613 void
1614 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1615 {
1616   int kind;
1617
1618   f->ts = matrix->ts;
1619   f->rank = 2;
1620   if (matrix->shape)
1621     {
1622       f->shape = gfc_get_shape (2);
1623       mpz_init_set (f->shape[0], matrix->shape[1]);
1624       mpz_init_set (f->shape[1], matrix->shape[0]);
1625     }
1626
1627   kind = matrix->ts.kind;
1628
1629   switch (kind)
1630     {
1631     case 4:
1632     case 8:
1633     case 10:
1634     case 16:
1635       switch (matrix->ts.type)
1636         {
1637         case BT_COMPLEX:
1638           f->value.function.name =
1639             gfc_get_string (PREFIX("transpose_c%d"), kind);
1640           break;
1641
1642         case BT_INTEGER:
1643         case BT_REAL:
1644         case BT_LOGICAL:
1645           /* Use the integer routines for real and logical cases.  This
1646              assumes they all have the same alignment requirements.  */
1647           f->value.function.name =
1648             gfc_get_string (PREFIX("transpose_i%d"), kind);
1649           break;
1650
1651         default:
1652           f->value.function.name = PREFIX("transpose");
1653           break;
1654         }
1655       break;
1656
1657     default:
1658       f->value.function.name = (matrix->ts.type == BT_CHARACTER
1659                                 ? PREFIX("transpose_char")
1660                                 : PREFIX("transpose"));
1661       break;
1662     }
1663 }
1664
1665
1666 void
1667 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1668 {
1669   f->ts.type = BT_CHARACTER;
1670   f->ts.kind = string->ts.kind;
1671   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1672 }
1673
1674
1675 void
1676 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1677                     gfc_expr * dim)
1678 {
1679   static char ubound[] = "__ubound";
1680
1681   f->ts.type = BT_INTEGER;
1682   f->ts.kind = gfc_default_integer_kind;
1683
1684   if (dim == NULL)
1685     {
1686       f->rank = 1;
1687       f->shape = gfc_get_shape (1);
1688       mpz_init_set_ui (f->shape[0], array->rank);
1689     }
1690
1691   f->value.function.name = ubound;
1692 }
1693
1694
1695 /* Resolve the g77 compatibility function UMASK.  */
1696
1697 void
1698 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1699 {
1700   f->ts.type = BT_INTEGER;
1701   f->ts.kind = n->ts.kind;
1702   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1703 }
1704
1705
1706 /* Resolve the g77 compatibility function UNLINK.  */
1707
1708 void
1709 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1710 {
1711   f->ts.type = BT_INTEGER;
1712   f->ts.kind = 4;
1713   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1714 }
1715
1716 void
1717 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1718                     gfc_expr * field ATTRIBUTE_UNUSED)
1719 {
1720   f->ts = vector->ts;
1721   f->rank = mask->rank;
1722
1723   f->value.function.name =
1724     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1725                     vector->ts.type == BT_CHARACTER ? "_char" : "");
1726 }
1727
1728
1729 void
1730 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1731                     gfc_expr * set ATTRIBUTE_UNUSED,
1732                     gfc_expr * back ATTRIBUTE_UNUSED)
1733 {
1734   f->ts.type = BT_INTEGER;
1735   f->ts.kind = gfc_default_integer_kind;
1736   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1737 }
1738
1739
1740 /* Intrinsic subroutine resolution.  */
1741
1742 void
1743 gfc_resolve_alarm_sub (gfc_code * c)
1744 {
1745   const char *name;
1746   gfc_expr *seconds, *handler, *status;
1747   gfc_typespec ts;
1748
1749   seconds = c->ext.actual->expr;
1750   handler = c->ext.actual->next->expr;
1751   status = c->ext.actual->next->next->expr;
1752   ts.type = BT_INTEGER;
1753   ts.kind = gfc_c_int_kind;
1754
1755   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
1756   if (handler->ts.type == BT_INTEGER)
1757     {
1758       if (handler->ts.kind != gfc_c_int_kind)
1759         gfc_convert_type (handler, &ts, 2);
1760       name = gfc_get_string (PREFIX("alarm_sub_int"));
1761     }
1762   else
1763     name = gfc_get_string (PREFIX("alarm_sub"));
1764
1765   if (seconds->ts.kind != gfc_c_int_kind)
1766     gfc_convert_type (seconds, &ts, 2);
1767   if (status != NULL && status->ts.kind != gfc_c_int_kind)
1768     gfc_convert_type (status, &ts, 2);
1769
1770   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1771 }
1772
1773 void
1774 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1775 {
1776   const char *name;
1777
1778   name = gfc_get_string (PREFIX("cpu_time_%d"),
1779                          c->ext.actual->expr->ts.kind);
1780   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1781 }
1782
1783
1784 void
1785 gfc_resolve_mvbits (gfc_code * c)
1786 {
1787   const char *name;
1788   int kind;
1789
1790   kind = c->ext.actual->expr->ts.kind;
1791   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1792
1793   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1794 }
1795
1796
1797 void
1798 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1799 {
1800   const char *name;
1801   int kind;
1802
1803   kind = c->ext.actual->expr->ts.kind;
1804   if (c->ext.actual->expr->rank == 0)
1805     name = gfc_get_string (PREFIX("random_r%d"), kind);
1806   else
1807     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1808
1809   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1810 }
1811
1812
1813 void
1814 gfc_resolve_rename_sub (gfc_code * c)
1815 {
1816   const char *name;
1817   int kind;
1818
1819   if (c->ext.actual->next->next->expr != NULL)
1820     kind = c->ext.actual->next->next->expr->ts.kind;
1821   else
1822     kind = gfc_default_integer_kind;
1823
1824   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1825   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1826 }
1827
1828
1829 void
1830 gfc_resolve_kill_sub (gfc_code * c)
1831 {
1832   const char *name;
1833   int kind;
1834
1835   if (c->ext.actual->next->next->expr != NULL)
1836     kind = c->ext.actual->next->next->expr->ts.kind;
1837   else
1838     kind = gfc_default_integer_kind;
1839
1840   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1841   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1842 }
1843
1844
1845 void
1846 gfc_resolve_link_sub (gfc_code * c)
1847 {
1848   const char *name;
1849   int kind;
1850
1851   if (c->ext.actual->next->next->expr != NULL)
1852     kind = c->ext.actual->next->next->expr->ts.kind;
1853   else
1854     kind = gfc_default_integer_kind;
1855
1856   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1857   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1858 }
1859
1860
1861 void
1862 gfc_resolve_symlnk_sub (gfc_code * c)
1863 {
1864   const char *name;
1865   int kind;
1866
1867   if (c->ext.actual->next->next->expr != NULL)
1868     kind = c->ext.actual->next->next->expr->ts.kind;
1869   else
1870     kind = gfc_default_integer_kind;
1871
1872   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1873   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1874 }
1875
1876
1877 /* G77 compatibility subroutines etime() and dtime().  */
1878
1879 void
1880 gfc_resolve_etime_sub (gfc_code * c)
1881 {
1882   const char *name;
1883
1884   name = gfc_get_string (PREFIX("etime_sub"));
1885   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1886 }
1887
1888
1889 /* G77 compatibility subroutine second().  */
1890
1891 void
1892 gfc_resolve_second_sub (gfc_code * c)
1893 {
1894   const char *name;
1895
1896   name = gfc_get_string (PREFIX("second_sub"));
1897   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1898 }
1899
1900
1901 void
1902 gfc_resolve_sleep_sub (gfc_code * c)
1903 {
1904   const char *name;
1905   int kind;
1906
1907   if (c->ext.actual->expr != NULL)
1908     kind = c->ext.actual->expr->ts.kind;
1909   else
1910     kind = gfc_default_integer_kind;
1911
1912   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1913   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1914 }
1915
1916
1917 /* G77 compatibility function srand().  */
1918
1919 void
1920 gfc_resolve_srand (gfc_code * c)
1921 {
1922   const char *name;
1923   name = gfc_get_string (PREFIX("srand"));
1924   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1925 }
1926
1927
1928 /* Resolve the getarg intrinsic subroutine.  */
1929
1930 void
1931 gfc_resolve_getarg (gfc_code * c)
1932 {
1933   const char *name;
1934   int kind;
1935
1936   kind = gfc_default_integer_kind;
1937   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1938   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1939 }
1940
1941 /* Resolve the getcwd intrinsic subroutine.  */
1942
1943 void
1944 gfc_resolve_getcwd_sub (gfc_code * c)
1945 {
1946   const char *name;
1947   int kind;
1948
1949   if (c->ext.actual->next->expr != NULL)
1950     kind = c->ext.actual->next->expr->ts.kind;
1951   else
1952     kind = gfc_default_integer_kind;
1953
1954   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1955   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1956 }
1957
1958
1959 /* Resolve the get_command intrinsic subroutine.  */
1960
1961 void
1962 gfc_resolve_get_command (gfc_code * c)
1963 {
1964   const char *name;
1965   int kind;
1966
1967   kind = gfc_default_integer_kind;
1968   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1969   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1970 }
1971
1972
1973 /* Resolve the get_command_argument intrinsic subroutine.  */
1974
1975 void
1976 gfc_resolve_get_command_argument (gfc_code * c)
1977 {
1978   const char *name;
1979   int kind;
1980
1981   kind = gfc_default_integer_kind;
1982   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1983   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1984 }
1985
1986 /* Resolve the get_environment_variable intrinsic subroutine.  */
1987
1988 void
1989 gfc_resolve_get_environment_variable (gfc_code * code)
1990 {
1991   const char *name;
1992   int kind;
1993
1994   kind = gfc_default_integer_kind;
1995   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1996   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1997 }
1998
1999 void
2000 gfc_resolve_signal_sub (gfc_code * c)
2001 {
2002   const char *name;
2003   gfc_expr *number, *handler, *status;
2004   gfc_typespec ts;
2005
2006   number = c->ext.actual->expr;
2007   handler = c->ext.actual->next->expr;
2008   status = c->ext.actual->next->next->expr;
2009   ts.type = BT_INTEGER;
2010   ts.kind = gfc_c_int_kind;
2011
2012   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2013   if (handler->ts.type == BT_INTEGER)
2014     {
2015       if (handler->ts.kind != gfc_c_int_kind)
2016         gfc_convert_type (handler, &ts, 2);
2017       name = gfc_get_string (PREFIX("signal_sub_int"));
2018     }
2019   else
2020     name = gfc_get_string (PREFIX("signal_sub"));
2021
2022   if (number->ts.kind != gfc_c_int_kind)
2023     gfc_convert_type (number, &ts, 2);
2024   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2025     gfc_convert_type (status, &ts, 2);
2026
2027   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2028 }
2029
2030 /* Resolve the SYSTEM intrinsic subroutine.  */
2031
2032 void
2033 gfc_resolve_system_sub (gfc_code * c)
2034 {
2035   const char *name;
2036
2037   name = gfc_get_string (PREFIX("system_sub"));
2038   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2039 }
2040
2041 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2042
2043 void
2044 gfc_resolve_system_clock (gfc_code * c)
2045 {
2046   const char *name;
2047   int kind;
2048
2049   if (c->ext.actual->expr != NULL)
2050     kind = c->ext.actual->expr->ts.kind;
2051   else if (c->ext.actual->next->expr != NULL)
2052       kind = c->ext.actual->next->expr->ts.kind;
2053   else if (c->ext.actual->next->next->expr != NULL)
2054       kind = c->ext.actual->next->next->expr->ts.kind;
2055   else
2056     kind = gfc_default_integer_kind;
2057
2058   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
2059   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2060 }
2061
2062 /* Resolve the EXIT intrinsic subroutine.  */
2063
2064 void
2065 gfc_resolve_exit (gfc_code * c)
2066 {
2067   const char *name;
2068   int kind;
2069
2070   if (c->ext.actual->expr != NULL)
2071     kind = c->ext.actual->expr->ts.kind;
2072   else
2073     kind = gfc_default_integer_kind;
2074
2075   name = gfc_get_string (PREFIX("exit_i%d"), kind);
2076   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2077 }
2078
2079 /* Resolve the FLUSH intrinsic subroutine.  */
2080
2081 void
2082 gfc_resolve_flush (gfc_code * c)
2083 {
2084   const char *name;
2085   gfc_typespec ts;
2086   gfc_expr *n;
2087
2088   ts.type = BT_INTEGER;
2089   ts.kind = gfc_default_integer_kind;
2090   n = c->ext.actual->expr;
2091   if (n != NULL
2092       && n->ts.kind != ts.kind)
2093     gfc_convert_type (n, &ts, 2);
2094
2095   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
2096   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2097 }
2098
2099
2100 void
2101 gfc_resolve_free (gfc_code * c)
2102 {
2103   gfc_typespec ts;
2104   gfc_expr *n;
2105
2106   ts.type = BT_INTEGER;
2107   ts.kind = gfc_index_integer_kind;
2108   n = c->ext.actual->expr;
2109   if (n->ts.kind != ts.kind)
2110     gfc_convert_type (n, &ts, 2);
2111
2112   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("free"));
2113 }
2114
2115
2116 void
2117 gfc_resolve_gerror (gfc_code * c)
2118 {
2119   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2120 }
2121
2122
2123 void
2124 gfc_resolve_getlog (gfc_code * c)
2125 {
2126   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2127 }
2128
2129
2130 void
2131 gfc_resolve_hostnm_sub (gfc_code * c)
2132 {
2133   const char *name;
2134   int kind;
2135
2136   if (c->ext.actual->next->expr != NULL)
2137     kind = c->ext.actual->next->expr->ts.kind;
2138   else
2139     kind = gfc_default_integer_kind;
2140
2141   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2142   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2143 }
2144
2145
2146 void
2147 gfc_resolve_perror (gfc_code * c)
2148 {
2149   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2150 }
2151
2152 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2153
2154 void
2155 gfc_resolve_stat_sub (gfc_code * c)
2156 {
2157   const char *name;
2158
2159   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2160   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2161 }
2162
2163
2164 void
2165 gfc_resolve_fstat_sub (gfc_code * c)
2166 {
2167   const char *name;
2168   gfc_expr *u;
2169   gfc_typespec *ts;
2170
2171   u = c->ext.actual->expr;
2172   ts = &c->ext.actual->next->expr->ts;
2173   if (u->ts.kind != ts->kind)
2174     gfc_convert_type (u, ts, 2);
2175   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2176   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2177 }
2178
2179
2180 void
2181 gfc_resolve_ttynam_sub (gfc_code * c)
2182 {
2183   gfc_typespec ts;
2184
2185   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2186     {
2187       ts.type = BT_INTEGER;
2188       ts.kind = gfc_c_int_kind;
2189       ts.derived = NULL;
2190       ts.cl = NULL;
2191       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2192     }
2193
2194   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2195 }
2196
2197
2198 /* Resolve the UMASK intrinsic subroutine.  */
2199
2200 void
2201 gfc_resolve_umask_sub (gfc_code * c)
2202 {
2203   const char *name;
2204   int kind;
2205
2206   if (c->ext.actual->next->expr != NULL)
2207     kind = c->ext.actual->next->expr->ts.kind;
2208   else
2209     kind = gfc_default_integer_kind;
2210
2211   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2212   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2213 }
2214
2215 /* Resolve the UNLINK intrinsic subroutine.  */
2216
2217 void
2218 gfc_resolve_unlink_sub (gfc_code * c)
2219 {
2220   const char *name;
2221   int kind;
2222
2223   if (c->ext.actual->next->expr != NULL)
2224     kind = c->ext.actual->next->expr->ts.kind;
2225   else
2226     kind = gfc_default_integer_kind;
2227
2228   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2229   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2230 }