gcc/fortran/iresolve.c

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