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