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_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b)
 916 {
 917   gfc_expr temp;
 918
 919   if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
 920     {
 921       f->ts.type = BT_LOGICAL;
 922       f->ts.kind = gfc_default_logical_kind;
 923     }
 924   else
 925     {
 926       temp.expr_type = EXPR_OP;
 927       gfc_clear_ts (&temp.ts);
 928       temp.value.op.operator = INTRINSIC_NONE;
 929       temp.value.op.op1 = a;
 930       temp.value.op.op2 = b;
 931       gfc_type_convert_binary (&temp);
 932       f->ts = temp.ts;
 933     }
 934
 935   f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
 936
 937   f->value.function.name =
 938     gfc_get_string (PREFIX("matmul_%c%d"), gfc_type_letter (f->ts.type),
 939                     f->ts.kind);
 940 }
 941
 942
 943 static void
 944 gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args)
 945 {
 946   gfc_actual_arglist *a;
 947
 948   f->ts.type = args->expr->ts.type;
 949   f->ts.kind = args->expr->ts.kind;
 950   /* Find the largest type kind.  */
 951   for (a = args->next; a; a = a->next)
 952     {
 953       if (a->expr->ts.kind > f->ts.kind)
 954         f->ts.kind = a->expr->ts.kind;
 955     }
 956
 957   /* Convert all parameters to the required kind.  */
 958   for (a = args; a; a = a->next)
 959     {
 960       if (a->expr->ts.kind != f->ts.kind)
 961         gfc_convert_type (a->expr, &f->ts, 2);
 962     }
 963
 964   f->value.function.name =
 965     gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
 966 }
 967
 968
 969 void
 970 gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args)
 971 {
 972   gfc_resolve_minmax ("__max_%c%d", f, args);
 973 }
 974
 975
 976 void
 977 gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 978                     gfc_expr * mask)
 979 {
 980   const char *name;
 981
 982   f->ts.type = BT_INTEGER;
 983   f->ts.kind = gfc_default_integer_kind;
 984
 985   if (dim == NULL)
 986     f->rank = 1;
 987   else
 988     {
 989       f->rank = array->rank - 1;
 990       gfc_resolve_dim_arg (dim);
 991     }
 992
 993   name = mask ? "mmaxloc" : "maxloc";
 994   f->value.function.name =
 995     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
 996                     gfc_type_letter (array->ts.type), array->ts.kind);
 997 }
 998
 999
1000 void
1001 gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1002                     gfc_expr * mask)
1003 {
1004   f->ts = array->ts;
1005
1006   if (dim != NULL)
1007     {
1008       f->rank = array->rank - 1;
1009       gfc_resolve_dim_arg (dim);
1010     }
1011
1012   f->value.function.name =
1013     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mmaxval" : "maxval",
1014                     gfc_type_letter (array->ts.type), array->ts.kind);
1015 }
1016
1017
1018 void
1019 gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
1020                    gfc_expr * fsource ATTRIBUTE_UNUSED,
1021                    gfc_expr * mask ATTRIBUTE_UNUSED)
1022 {
1023   if (tsource->ts.type == BT_CHARACTER)
1024     check_charlen_present (tsource);
1025
1026   f->ts = tsource->ts;
1027   f->value.function.name =
1028     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1029                     tsource->ts.kind);
1030 }
1031
1032
1033 void
1034 gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args)
1035 {
1036   gfc_resolve_minmax ("__min_%c%d", f, args);
1037 }
1038
1039
1040 void
1041 gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1042                     gfc_expr * mask)
1043 {
1044   const char *name;
1045
1046   f->ts.type = BT_INTEGER;
1047   f->ts.kind = gfc_default_integer_kind;
1048
1049   if (dim == NULL)
1050     f->rank = 1;
1051   else
1052     {
1053       f->rank = array->rank - 1;
1054       gfc_resolve_dim_arg (dim);
1055     }
1056
1057   name = mask ? "mminloc" : "minloc";
1058   f->value.function.name =
1059     gfc_get_string (PREFIX("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1060                     gfc_type_letter (array->ts.type), array->ts.kind);
1061 }
1062
1063
1064 void
1065 gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1066                     gfc_expr * mask)
1067 {
1068   f->ts = array->ts;
1069
1070   if (dim != NULL)
1071     {
1072       f->rank = array->rank - 1;
1073       gfc_resolve_dim_arg (dim);
1074     }
1075
1076   f->value.function.name =
1077     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mminval" : "minval",
1078                     gfc_type_letter (array->ts.type), array->ts.kind);
1079 }
1080
1081
1082 void
1083 gfc_resolve_mod (gfc_expr * f, gfc_expr * a,
1084                  gfc_expr * p ATTRIBUTE_UNUSED)
1085 {
1086   f->ts = a->ts;
1087   f->value.function.name =
1088     gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1089 }
1090
1091
1092 void
1093 gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
1094                     gfc_expr * p ATTRIBUTE_UNUSED)
1095 {
1096   f->ts = a->ts;
1097   f->value.function.name =
1098     gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type),
1099                     a->ts.kind);
1100 }
1101
1102 void
1103 gfc_resolve_nearest (gfc_expr * f, gfc_expr * a, gfc_expr *p ATTRIBUTE_UNUSED)
1104 {
1105   f->ts = a->ts;
1106   f->value.function.name =
1107     gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
1108             a->ts.kind);
1109 }
1110
1111 void
1112 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1113 {
1114   f->ts.type = BT_INTEGER;
1115   f->ts.kind = (kind == NULL) ? gfc_default_integer_kind
1116     : mpz_get_si (kind->value.integer);
1117
1118   f->value.function.name =
1119     gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
1120 }
1121
1122
1123 void
1124 gfc_resolve_not (gfc_expr * f, gfc_expr * i)
1125 {
1126   f->ts = i->ts;
1127   f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
1128 }
1129
1130
1131 void
1132 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
1133                   gfc_expr * vector ATTRIBUTE_UNUSED)
1134 {
1135   f->ts = array->ts;
1136   f->rank = 1;
1137
1138   if (mask->rank != 0)
1139     f->value.function.name = (array->ts.type == BT_CHARACTER
1140                               ? PREFIX("pack_char")
1141                               : PREFIX("pack"));
1142   else
1143     {
1144       /* We convert mask to default logical only in the scalar case.
1145          In the array case we can simply read the array as if it were
1146          of type default logical.  */
1147       if (mask->ts.kind != gfc_default_logical_kind)
1148         {
1149           gfc_typespec ts;
1150
1151           ts.type = BT_LOGICAL;
1152           ts.kind = gfc_default_logical_kind;
1153           gfc_convert_type (mask, &ts, 2);
1154         }
1155
1156       f->value.function.name = (array->ts.type == BT_CHARACTER
1157                                 ? PREFIX("pack_s_char")
1158                                 : PREFIX("pack_s"));
1159     }
1160 }
1161
1162
1163 void
1164 gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1165                      gfc_expr * mask)
1166 {
1167   f->ts = array->ts;
1168
1169   if (dim != NULL)
1170     {
1171       f->rank = array->rank - 1;
1172       gfc_resolve_dim_arg (dim);
1173     }
1174
1175   f->value.function.name =
1176     gfc_get_string (PREFIX("%s_%c%d"), mask ? "mproduct" : "product",
1177                     gfc_type_letter (array->ts.type), array->ts.kind);
1178 }
1179
1180
1181 void
1182 gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
1183 {
1184   f->ts.type = BT_REAL;
1185
1186   if (kind != NULL)
1187     f->ts.kind = mpz_get_si (kind->value.integer);
1188   else
1189     f->ts.kind = (a->ts.type == BT_COMPLEX) ?
1190       a->ts.kind : gfc_default_real_kind;
1191
1192   f->value.function.name =
1193     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1194                     gfc_type_letter (a->ts.type), a->ts.kind);
1195 }
1196
1197
1198 void
1199 gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
1200 {
1201   f->ts.type = BT_REAL;
1202   f->ts.kind = a->ts.kind;
1203   f->value.function.name =
1204     gfc_get_string ("__real_%d_%c%d", f->ts.kind,
1205                     gfc_type_letter (a->ts.type), a->ts.kind);
1206 }
1207
1208
1209 void
1210 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1211                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1212 {
1213   f->ts.type = BT_INTEGER;
1214   f->ts.kind = gfc_default_integer_kind;
1215   f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
1216 }
1217
1218
1219 void
1220 gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
1221                     gfc_expr * ncopies ATTRIBUTE_UNUSED)
1222 {
1223   f->ts.type = BT_CHARACTER;
1224   f->ts.kind = string->ts.kind;
1225   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
1226 }
1227
1228
1229 void
1230 gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape,
1231                      gfc_expr * pad ATTRIBUTE_UNUSED,
1232                      gfc_expr * order ATTRIBUTE_UNUSED)
1233 {
1234   mpz_t rank;
1235   int kind;
1236   int i;
1237
1238   f->ts = source->ts;
1239
1240   gfc_array_size (shape, &rank);
1241   f->rank = mpz_get_si (rank);
1242   mpz_clear (rank);
1243   switch (source->ts.type)
1244     {
1245     case BT_COMPLEX:
1246       kind = source->ts.kind * 2;
1247       break;
1248
1249     case BT_REAL:
1250     case BT_INTEGER:
1251     case BT_LOGICAL:
1252       kind = source->ts.kind;
1253       break;
1254
1255     default:
1256       kind = 0;
1257       break;
1258     }
1259
1260   switch (kind)
1261     {
1262     case 4:
1263     case 8:
1264     case 10:
1265     case 16:
1266       if (source->ts.type == BT_COMPLEX)
1267         f->value.function.name =
1268           gfc_get_string (PREFIX("reshape_%c%d"),
1269                           gfc_type_letter (BT_COMPLEX), source->ts.kind);
1270       else
1271         f->value.function.name =
1272           gfc_get_string (PREFIX("reshape_%d"), source->ts.kind);
1273
1274       break;
1275
1276     default:
1277       f->value.function.name = (source->ts.type == BT_CHARACTER
1278                                 ? PREFIX("reshape_char")
1279                                 : PREFIX("reshape"));
1280       break;
1281     }
1282
1283   /* TODO: Make this work with a constant ORDER parameter.  */
1284   if (shape->expr_type == EXPR_ARRAY
1285       && gfc_is_constant_expr (shape)
1286       && order == NULL)
1287     {
1288       gfc_constructor *c;
1289       f->shape = gfc_get_shape (f->rank);
1290       c = shape->value.constructor;
1291       for (i = 0; i < f->rank; i++)
1292         {
1293           mpz_init_set (f->shape[i], c->expr->value.integer);
1294           c = c->next;
1295         }
1296     }
1297
1298   /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
1299      so many runtime variations.  */
1300   if (shape->ts.kind != gfc_index_integer_kind)
1301     {
1302       gfc_typespec ts = shape->ts;
1303       ts.kind = gfc_index_integer_kind;
1304       gfc_convert_type_warn (shape, &ts, 2, 0);
1305     }
1306   if (order && order->ts.kind != gfc_index_integer_kind)
1307     gfc_convert_type_warn (order, &shape->ts, 2, 0);
1308 }
1309
1310
1311 void
1312 gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x)
1313 {
1314   f->ts = x->ts;
1315   f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
1316 }
1317
1318
1319 void
1320 gfc_resolve_scale (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1321 {
1322   f->ts = x->ts;
1323
1324   /* The implementation calls scalbn which takes an int as the
1325      second argument.  */
1326   if (i->ts.kind != gfc_c_int_kind)
1327     {
1328       gfc_typespec ts;
1329
1330       ts.type = BT_INTEGER;
1331       ts.kind = gfc_default_integer_kind;
1332
1333       gfc_convert_type_warn (i, &ts, 2, 0);
1334     }
1335
1336   f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
1337 }
1338
1339
1340 void
1341 gfc_resolve_scan (gfc_expr * f, gfc_expr * string,
1342                   gfc_expr * set ATTRIBUTE_UNUSED,
1343                   gfc_expr * back ATTRIBUTE_UNUSED)
1344 {
1345   f->ts.type = BT_INTEGER;
1346   f->ts.kind = gfc_default_integer_kind;
1347   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
1348 }
1349
1350
1351 void
1352 gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i)
1353 {
1354   f->ts = x->ts;
1355
1356   /* The library implementation uses GFC_INTEGER_4 unconditionally,
1357      convert type so we don't have to implement all possible
1358      permutations.  */
1359   if (i->ts.kind != 4)
1360     {
1361       gfc_typespec ts;
1362
1363       ts.type = BT_INTEGER;
1364       ts.kind = gfc_default_integer_kind;
1365
1366       gfc_convert_type_warn (i, &ts, 2, 0);
1367     }
1368
1369   f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
1370 }
1371
1372
1373 void
1374 gfc_resolve_shape (gfc_expr * f, gfc_expr * array)
1375 {
1376   f->ts.type = BT_INTEGER;
1377   f->ts.kind = gfc_default_integer_kind;
1378   f->rank = 1;
1379   f->value.function.name = gfc_get_string (PREFIX("shape_%d"), f->ts.kind);
1380   f->shape = gfc_get_shape (1);
1381   mpz_init_set_ui (f->shape[0], array->rank);
1382 }
1383
1384
1385 void
1386 gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED)
1387 {
1388   f->ts = a->ts;
1389   f->value.function.name =
1390     gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
1391 }
1392
1393
1394 void
1395 gfc_resolve_sin (gfc_expr * f, gfc_expr * x)
1396 {
1397   f->ts = x->ts;
1398   f->value.function.name =
1399     gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1400 }
1401
1402
1403 void
1404 gfc_resolve_sinh (gfc_expr * f, gfc_expr * x)
1405 {
1406   f->ts = x->ts;
1407   f->value.function.name =
1408     gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1409 }
1410
1411
1412 void
1413 gfc_resolve_spacing (gfc_expr * f, gfc_expr * x)
1414 {
1415   f->ts = x->ts;
1416   f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
1417 }
1418
1419
1420 void
1421 gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
1422                     gfc_expr * dim,
1423                     gfc_expr * ncopies)
1424 {
1425   if (source->ts.type == BT_CHARACTER)
1426     check_charlen_present (source);
1427
1428   f->ts = source->ts;
1429   f->rank = source->rank + 1;
1430   if (source->rank == 0)
1431     f->value.function.name = (source->ts.type == BT_CHARACTER
1432                               ? PREFIX("spread_char_scalar")
1433                               : PREFIX("spread_scalar"));
1434   else
1435     f->value.function.name = (source->ts.type == BT_CHARACTER
1436                               ? PREFIX("spread_char")
1437                               : PREFIX("spread"));
1438
1439   gfc_resolve_dim_arg (dim);
1440   gfc_resolve_index (ncopies, 1);
1441 }
1442
1443
1444 void
1445 gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x)
1446 {
1447   f->ts = x->ts;
1448   f->value.function.name =
1449     gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1450 }
1451
1452
1453 /* Resolve the g77 compatibility function STAT AND FSTAT.  */
1454
1455 void
1456 gfc_resolve_stat (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED,
1457                   gfc_expr * a ATTRIBUTE_UNUSED)
1458 {
1459   f->ts.type = BT_INTEGER;
1460   f->ts.kind = gfc_default_integer_kind;
1461   f->value.function.name = gfc_get_string (PREFIX("stat_i%d"), f->ts.kind);
1462 }
1463
1464
1465 void
1466 gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
1467 {
1468   f->ts.type = BT_INTEGER;
1469   f->ts.kind = gfc_default_integer_kind;
1470   if (n->ts.kind != f->ts.kind)
1471     gfc_convert_type (n, &f->ts, 2);
1472
1473   f->value.function.name = gfc_get_string (PREFIX("fstat_i%d"), f->ts.kind);
1474 }
1475
1476
1477 void
1478 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
1479                  gfc_expr * mask)
1480 {
1481   f->ts = array->ts;
1482
1483   if (dim != NULL)
1484     {
1485       f->rank = array->rank - 1;
1486       gfc_resolve_dim_arg (dim);
1487     }
1488
1489   f->value.function.name =
1490     gfc_get_string (PREFIX("%s_%c%d"), mask ? "msum" : "sum",
1491                     gfc_type_letter (array->ts.type), array->ts.kind);
1492 }
1493
1494
1495 void
1496 gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
1497                     gfc_expr * p2 ATTRIBUTE_UNUSED)
1498 {
1499   f->ts.type = BT_INTEGER;
1500   f->ts.kind = gfc_default_integer_kind;
1501   f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
1502 }
1503
1504
1505 /* Resolve the g77 compatibility function SYSTEM.  */
1506
1507 void
1508 gfc_resolve_system (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1509 {
1510   f->ts.type = BT_INTEGER;
1511   f->ts.kind = 4;
1512   f->value.function.name = gfc_get_string (PREFIX("system"));
1513 }
1514
1515
1516 void
1517 gfc_resolve_tan (gfc_expr * f, gfc_expr * x)
1518 {
1519   f->ts = x->ts;
1520   f->value.function.name =
1521     gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1522 }
1523
1524
1525 void
1526 gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
1527 {
1528   f->ts = x->ts;
1529   f->value.function.name =
1530     gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1531 }
1532
1533
1534 void
1535 gfc_resolve_time (gfc_expr * f)
1536 {
1537   f->ts.type = BT_INTEGER;
1538   f->ts.kind = 4;
1539   f->value.function.name = gfc_get_string (PREFIX("time_func"));
1540 }
1541
1542
1543 void
1544 gfc_resolve_time8 (gfc_expr * f)
1545 {
1546   f->ts.type = BT_INTEGER;
1547   f->ts.kind = 8;
1548   f->value.function.name = gfc_get_string (PREFIX("time8_func"));
1549 }
1550
1551
1552 void
1553 gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
1554                       gfc_expr * mold, gfc_expr * size)
1555 {
1556   /* TODO: Make this do something meaningful.  */
1557   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
1558
1559   f->ts = mold->ts;
1560
1561   if (size == NULL && mold->rank == 0)
1562     {
1563       f->rank = 0;
1564       f->value.function.name = transfer0;
1565     }
1566   else
1567     {
1568       f->rank = 1;
1569       f->value.function.name = transfer1;
1570     }
1571 }
1572
1573
1574 void
1575 gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
1576 {
1577   int kind;
1578
1579   f->ts = matrix->ts;
1580   f->rank = 2;
1581   if (matrix->shape)
1582     {
1583       f->shape = gfc_get_shape (2);
1584       mpz_init_set (f->shape[0], matrix->shape[1]);
1585       mpz_init_set (f->shape[1], matrix->shape[0]);
1586     }
1587
1588   kind = matrix->ts.kind;
1589
1590   switch (kind)
1591     {
1592     case 4:
1593     case 8:
1594     case 10:
1595     case 16:
1596       switch (matrix->ts.type)
1597         {
1598         case BT_COMPLEX:
1599           f->value.function.name =
1600             gfc_get_string (PREFIX("transpose_c%d"), kind);
1601           break;
1602
1603         case BT_INTEGER:
1604         case BT_REAL:
1605         case BT_LOGICAL:
1606           /* Use the integer routines for real and logical cases.  This
1607              assumes they all have the same alignment requirements.  */
1608           f->value.function.name =
1609             gfc_get_string (PREFIX("transpose_i%d"), kind);
1610           break;
1611
1612         default:
1613           f->value.function.name = PREFIX("transpose");
1614           break;
1615         }
1616       break;
1617
1618     default:
1619       f->value.function.name = (matrix->ts.type == BT_CHARACTER
1620                                 ? PREFIX("transpose_char")
1621                                 : PREFIX("transpose"));
1622       break;
1623     }
1624 }
1625
1626
1627 void
1628 gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
1629 {
1630   f->ts.type = BT_CHARACTER;
1631   f->ts.kind = string->ts.kind;
1632   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
1633 }
1634
1635
1636 void
1637 gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
1638                     gfc_expr * dim)
1639 {
1640   static char ubound[] = "__ubound";
1641
1642   f->ts.type = BT_INTEGER;
1643   f->ts.kind = gfc_default_integer_kind;
1644
1645   if (dim == NULL)
1646     {
1647       f->rank = 1;
1648       f->shape = gfc_get_shape (1);
1649       mpz_init_set_ui (f->shape[0], array->rank);
1650     }
1651
1652   f->value.function.name = ubound;
1653 }
1654
1655
1656 /* Resolve the g77 compatibility function UMASK.  */
1657
1658 void
1659 gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
1660 {
1661   f->ts.type = BT_INTEGER;
1662   f->ts.kind = n->ts.kind;
1663   f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
1664 }
1665
1666
1667 /* Resolve the g77 compatibility function UNLINK.  */
1668
1669 void
1670 gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
1671 {
1672   f->ts.type = BT_INTEGER;
1673   f->ts.kind = 4;
1674   f->value.function.name = gfc_get_string (PREFIX("unlink"));
1675 }
1676
1677 void
1678 gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
1679                     gfc_expr * field ATTRIBUTE_UNUSED)
1680 {
1681   f->ts = vector->ts;
1682   f->rank = mask->rank;
1683
1684   f->value.function.name =
1685     gfc_get_string (PREFIX("unpack%d%s"), field->rank > 0 ? 1 : 0,
1686                     vector->ts.type == BT_CHARACTER ? "_char" : "");
1687 }
1688
1689
1690 void
1691 gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
1692                     gfc_expr * set ATTRIBUTE_UNUSED,
1693                     gfc_expr * back ATTRIBUTE_UNUSED)
1694 {
1695   f->ts.type = BT_INTEGER;
1696   f->ts.kind = gfc_default_integer_kind;
1697   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
1698 }
1699
1700
1701 /* Intrinsic subroutine resolution.  */
1702
1703 void
1704 gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED)
1705 {
1706   const char *name;
1707
1708   name = gfc_get_string (PREFIX("cpu_time_%d"),
1709                          c->ext.actual->expr->ts.kind);
1710   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1711 }
1712
1713
1714 void
1715 gfc_resolve_mvbits (gfc_code * c)
1716 {
1717   const char *name;
1718   int kind;
1719
1720   kind = c->ext.actual->expr->ts.kind;
1721   name = gfc_get_string (PREFIX("mvbits_i%d"), kind);
1722
1723   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1724 }
1725
1726
1727 void
1728 gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
1729 {
1730   const char *name;
1731   int kind;
1732
1733   kind = c->ext.actual->expr->ts.kind;
1734   if (c->ext.actual->expr->rank == 0)
1735     name = gfc_get_string (PREFIX("random_r%d"), kind);
1736   else
1737     name = gfc_get_string (PREFIX("arandom_r%d"), kind);
1738
1739   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1740 }
1741
1742
1743 void
1744 gfc_resolve_rename_sub (gfc_code * c)
1745 {
1746   const char *name;
1747   int kind;
1748
1749   if (c->ext.actual->next->next->expr != NULL)
1750     kind = c->ext.actual->next->next->expr->ts.kind;
1751   else
1752     kind = gfc_default_integer_kind;
1753
1754   name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
1755   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1756 }
1757
1758
1759 void
1760 gfc_resolve_kill_sub (gfc_code * c)
1761 {
1762   const char *name;
1763   int kind;
1764
1765   if (c->ext.actual->next->next->expr != NULL)
1766     kind = c->ext.actual->next->next->expr->ts.kind;
1767   else
1768     kind = gfc_default_integer_kind;
1769
1770   name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
1771   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1772 }
1773
1774
1775 void
1776 gfc_resolve_link_sub (gfc_code * c)
1777 {
1778   const char *name;
1779   int kind;
1780
1781   if (c->ext.actual->next->next->expr != NULL)
1782     kind = c->ext.actual->next->next->expr->ts.kind;
1783   else
1784     kind = gfc_default_integer_kind;
1785
1786   name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
1787   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1788 }
1789
1790
1791 void
1792 gfc_resolve_symlnk_sub (gfc_code * c)
1793 {
1794   const char *name;
1795   int kind;
1796
1797   if (c->ext.actual->next->next->expr != NULL)
1798     kind = c->ext.actual->next->next->expr->ts.kind;
1799   else
1800     kind = gfc_default_integer_kind;
1801
1802   name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
1803   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1804 }
1805
1806
1807 /* G77 compatibility subroutines etime() and dtime().  */
1808
1809 void
1810 gfc_resolve_etime_sub (gfc_code * c)
1811 {
1812   const char *name;
1813
1814   name = gfc_get_string (PREFIX("etime_sub"));
1815   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1816 }
1817
1818
1819 /* G77 compatibility subroutine second().  */
1820
1821 void
1822 gfc_resolve_second_sub (gfc_code * c)
1823 {
1824   const char *name;
1825
1826   name = gfc_get_string (PREFIX("second_sub"));
1827   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1828 }
1829
1830
1831 void
1832 gfc_resolve_sleep_sub (gfc_code * c)
1833 {
1834   const char *name;
1835   int kind;
1836
1837   if (c->ext.actual->expr != NULL)
1838     kind = c->ext.actual->expr->ts.kind;
1839   else
1840     kind = gfc_default_integer_kind;
1841
1842   name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
1843   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1844 }
1845
1846
1847 /* G77 compatibility function srand().  */
1848
1849 void
1850 gfc_resolve_srand (gfc_code * c)
1851 {
1852   const char *name;
1853   name = gfc_get_string (PREFIX("srand"));
1854   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1855 }
1856
1857
1858 /* Resolve the getarg intrinsic subroutine.  */
1859
1860 void
1861 gfc_resolve_getarg (gfc_code * c)
1862 {
1863   const char *name;
1864   int kind;
1865
1866   kind = gfc_default_integer_kind;
1867   name = gfc_get_string (PREFIX("getarg_i%d"), kind);
1868   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1869 }
1870
1871 /* Resolve the getcwd intrinsic subroutine.  */
1872
1873 void
1874 gfc_resolve_getcwd_sub (gfc_code * c)
1875 {
1876   const char *name;
1877   int kind;
1878
1879   if (c->ext.actual->next->expr != NULL)
1880     kind = c->ext.actual->next->expr->ts.kind;
1881   else
1882     kind = gfc_default_integer_kind;
1883
1884   name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
1885   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1886 }
1887
1888
1889 /* Resolve the get_command intrinsic subroutine.  */
1890
1891 void
1892 gfc_resolve_get_command (gfc_code * c)
1893 {
1894   const char *name;
1895   int kind;
1896
1897   kind = gfc_default_integer_kind;
1898   name = gfc_get_string (PREFIX("get_command_i%d"), kind);
1899   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1900 }
1901
1902
1903 /* Resolve the get_command_argument intrinsic subroutine.  */
1904
1905 void
1906 gfc_resolve_get_command_argument (gfc_code * c)
1907 {
1908   const char *name;
1909   int kind;
1910
1911   kind = gfc_default_integer_kind;
1912   name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
1913   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1914 }
1915
1916 /* Resolve the get_environment_variable intrinsic subroutine.  */
1917
1918 void
1919 gfc_resolve_get_environment_variable (gfc_code * code)
1920 {
1921   const char *name;
1922   int kind;
1923
1924   kind = gfc_default_integer_kind;
1925   name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
1926   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1927 }
1928
1929 /* Resolve the SYSTEM intrinsic subroutine.  */
1930
1931 void
1932 gfc_resolve_system_sub (gfc_code * c)
1933 {
1934   const char *name;
1935
1936   name = gfc_get_string (PREFIX("system_sub"));
1937   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1938 }
1939
1940 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1941
1942 void
1943 gfc_resolve_system_clock (gfc_code * c)
1944 {
1945   const char *name;
1946   int kind;
1947
1948   if (c->ext.actual->expr != NULL)
1949     kind = c->ext.actual->expr->ts.kind;
1950   else if (c->ext.actual->next->expr != NULL)
1951       kind = c->ext.actual->next->expr->ts.kind;
1952   else if (c->ext.actual->next->next->expr != NULL)
1953       kind = c->ext.actual->next->next->expr->ts.kind;
1954   else
1955     kind = gfc_default_integer_kind;
1956
1957   name = gfc_get_string (PREFIX("system_clock_%d"), kind);
1958   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1959 }
1960
1961 /* Resolve the EXIT intrinsic subroutine.  */
1962
1963 void
1964 gfc_resolve_exit (gfc_code * c)
1965 {
1966   const char *name;
1967   int kind;
1968
1969   if (c->ext.actual->expr != NULL)
1970     kind = c->ext.actual->expr->ts.kind;
1971   else
1972     kind = gfc_default_integer_kind;
1973
1974   name = gfc_get_string (PREFIX("exit_i%d"), kind);
1975   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1976 }
1977
1978 /* Resolve the FLUSH intrinsic subroutine.  */
1979
1980 void
1981 gfc_resolve_flush (gfc_code * c)
1982 {
1983   const char *name;
1984   gfc_typespec ts;
1985   gfc_expr *n;
1986
1987   ts.type = BT_INTEGER;
1988   ts.kind = gfc_default_integer_kind;
1989   n = c->ext.actual->expr;
1990   if (n != NULL
1991       && n->ts.kind != ts.kind)
1992     gfc_convert_type (n, &ts, 2);
1993
1994   name = gfc_get_string (PREFIX("flush_i%d"), ts.kind);
1995   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
1996 }
1997
1998
1999 void
2000 gfc_resolve_gerror (gfc_code * c)
2001 {
2002   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2003 }
2004
2005
2006 void
2007 gfc_resolve_getlog (gfc_code * c)
2008 {
2009   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2010 }
2011
2012
2013 void
2014 gfc_resolve_hostnm_sub (gfc_code * c)
2015 {
2016   const char *name;
2017   int kind;
2018
2019   if (c->ext.actual->next->expr != NULL)
2020     kind = c->ext.actual->next->expr->ts.kind;
2021   else
2022     kind = gfc_default_integer_kind;
2023
2024   name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
2025   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2026 }
2027
2028
2029 void
2030 gfc_resolve_perror (gfc_code * c)
2031 {
2032   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2033 }
2034
2035 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2036
2037 void
2038 gfc_resolve_stat_sub (gfc_code * c)
2039 {
2040   const char *name;
2041
2042   name = gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind);
2043   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2044 }
2045
2046
2047 void
2048 gfc_resolve_fstat_sub (gfc_code * c)
2049 {
2050   const char *name;
2051   gfc_expr *u;
2052   gfc_typespec *ts;
2053
2054   u = c->ext.actual->expr;
2055   ts = &c->ext.actual->next->expr->ts;
2056   if (u->ts.kind != ts->kind)
2057     gfc_convert_type (u, ts, 2);
2058   name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
2059   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2060 }
2061
2062
2063 void
2064 gfc_resolve_ttynam_sub (gfc_code * c)
2065 {
2066   gfc_typespec ts;
2067
2068   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2069     {
2070       ts.type = BT_INTEGER;
2071       ts.kind = gfc_c_int_kind;
2072       ts.derived = NULL;
2073       ts.cl = NULL;
2074       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2075     }
2076
2077   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
2078 }
2079
2080
2081 /* Resolve the UMASK intrinsic subroutine.  */
2082
2083 void
2084 gfc_resolve_umask_sub (gfc_code * c)
2085 {
2086   const char *name;
2087   int kind;
2088
2089   if (c->ext.actual->next->expr != NULL)
2090     kind = c->ext.actual->next->expr->ts.kind;
2091   else
2092     kind = gfc_default_integer_kind;
2093
2094   name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
2095   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2096 }
2097
2098 /* Resolve the UNLINK intrinsic subroutine.  */
2099
2100 void
2101 gfc_resolve_unlink_sub (gfc_code * c)
2102 {
2103   const char *name;
2104   int kind;
2105
2106   if (c->ext.actual->next->expr != NULL)
2107     kind = c->ext.actual->next->expr->ts.kind;
2108   else
2109     kind = gfc_default_integer_kind;
2110
2111   name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
2112   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2113 }