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 : shift->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   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2390     gfc_convert_type (status, &ts, 2);
2391
2392   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2393 }
2394
2395 void
2396 gfc_resolve_cpu_time (gfc_code *c)
2397 {
2398   const char *name;
2399   name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
2400   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2401 }
2402
2403
2404 void
2405 gfc_resolve_mvbits (gfc_code *c)
2406 {
2407   const char *name;
2408   int kind;
2409   kind = c->ext.actual->expr->ts.kind;
2410   name = gfc_get_string (PREFIX ("mvbits_i%d"), kind);
2411   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2412 }
2413
2414
2415 void
2416 gfc_resolve_random_number (gfc_code *c)
2417 {
2418   const char *name;
2419   int kind;
2420
2421   kind = c->ext.actual->expr->ts.kind;
2422   if (c->ext.actual->expr->rank == 0)
2423     name = gfc_get_string (PREFIX ("random_r%d"), kind);
2424   else
2425     name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
2426
2427   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2428 }
2429
2430
2431 void
2432 gfc_resolve_rename_sub (gfc_code *c)
2433 {
2434   const char *name;
2435   int kind;
2436
2437   if (c->ext.actual->next->next->expr != NULL)
2438     kind = c->ext.actual->next->next->expr->ts.kind;
2439   else
2440     kind = gfc_default_integer_kind;
2441
2442   name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
2443   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2444 }
2445
2446
2447 void
2448 gfc_resolve_kill_sub (gfc_code *c)
2449 {
2450   const char *name;
2451   int kind;
2452
2453   if (c->ext.actual->next->next->expr != NULL)
2454     kind = c->ext.actual->next->next->expr->ts.kind;
2455   else
2456     kind = gfc_default_integer_kind;
2457
2458   name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
2459   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2460 }
2461
2462
2463 void
2464 gfc_resolve_link_sub (gfc_code *c)
2465 {
2466   const char *name;
2467   int kind;
2468
2469   if (c->ext.actual->next->next->expr != NULL)
2470     kind = c->ext.actual->next->next->expr->ts.kind;
2471   else
2472     kind = gfc_default_integer_kind;
2473
2474   name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
2475   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2476 }
2477
2478
2479 void
2480 gfc_resolve_symlnk_sub (gfc_code *c)
2481 {
2482   const char *name;
2483   int kind;
2484
2485   if (c->ext.actual->next->next->expr != NULL)
2486     kind = c->ext.actual->next->next->expr->ts.kind;
2487   else
2488     kind = gfc_default_integer_kind;
2489
2490   name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
2491   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2492 }
2493
2494
2495 /* G77 compatibility subroutines etime() and dtime().  */
2496
2497 void
2498 gfc_resolve_etime_sub (gfc_code *c)
2499 {
2500   const char *name;
2501   name = gfc_get_string (PREFIX ("etime_sub"));
2502   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2503 }
2504
2505
2506 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime().  */
2507
2508 void
2509 gfc_resolve_itime (gfc_code *c)
2510 {
2511   c->resolved_sym
2512     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
2513                                                     gfc_default_integer_kind));
2514 }
2515
2516 void
2517 gfc_resolve_idate (gfc_code *c)
2518 {
2519   c->resolved_sym
2520     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
2521                                                     gfc_default_integer_kind));
2522 }
2523
2524 void
2525 gfc_resolve_ltime (gfc_code *c)
2526 {
2527   c->resolved_sym
2528     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
2529                                                     gfc_default_integer_kind));
2530 }
2531
2532 void
2533 gfc_resolve_gmtime (gfc_code *c)
2534 {
2535   c->resolved_sym
2536     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
2537                                                     gfc_default_integer_kind));
2538 }
2539
2540
2541 /* G77 compatibility subroutine second().  */
2542
2543 void
2544 gfc_resolve_second_sub (gfc_code *c)
2545 {
2546   const char *name;
2547   name = gfc_get_string (PREFIX ("second_sub"));
2548   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2549 }
2550
2551
2552 void
2553 gfc_resolve_sleep_sub (gfc_code *c)
2554 {
2555   const char *name;
2556   int kind;
2557
2558   if (c->ext.actual->expr != NULL)
2559     kind = c->ext.actual->expr->ts.kind;
2560   else
2561     kind = gfc_default_integer_kind;
2562
2563   name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
2564   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2565 }
2566
2567
2568 /* G77 compatibility function srand().  */
2569
2570 void
2571 gfc_resolve_srand (gfc_code *c)
2572 {
2573   const char *name;
2574   name = gfc_get_string (PREFIX ("srand"));
2575   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2576 }
2577
2578
2579 /* Resolve the getarg intrinsic subroutine.  */
2580
2581 void
2582 gfc_resolve_getarg (gfc_code *c)
2583 {
2584   const char *name;
2585   int kind;
2586   kind = gfc_default_integer_kind;
2587   name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
2588   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2589 }
2590
2591
2592 /* Resolve the getcwd intrinsic subroutine.  */
2593
2594 void
2595 gfc_resolve_getcwd_sub (gfc_code *c)
2596 {
2597   const char *name;
2598   int kind;
2599
2600   if (c->ext.actual->next->expr != NULL)
2601     kind = c->ext.actual->next->expr->ts.kind;
2602   else
2603     kind = gfc_default_integer_kind;
2604
2605   name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
2606   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2607 }
2608
2609
2610 /* Resolve the get_command intrinsic subroutine.  */
2611
2612 void
2613 gfc_resolve_get_command (gfc_code *c)
2614 {
2615   const char *name;
2616   int kind;
2617   kind = gfc_default_integer_kind;
2618   name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
2619   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2620 }
2621
2622
2623 /* Resolve the get_command_argument intrinsic subroutine.  */
2624
2625 void
2626 gfc_resolve_get_command_argument (gfc_code *c)
2627 {
2628   const char *name;
2629   int kind;
2630   kind = gfc_default_integer_kind;
2631   name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
2632   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2633 }
2634
2635
2636 /* Resolve the get_environment_variable intrinsic subroutine.  */
2637
2638 void
2639 gfc_resolve_get_environment_variable (gfc_code *code)
2640 {
2641   const char *name;
2642   int kind;
2643   kind = gfc_default_integer_kind;
2644   name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
2645   code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2646 }
2647
2648
2649 void
2650 gfc_resolve_signal_sub (gfc_code *c)
2651 {
2652   const char *name;
2653   gfc_expr *number, *handler, *status;
2654   gfc_typespec ts;
2655
2656   number = c->ext.actual->expr;
2657   handler = c->ext.actual->next->expr;
2658   status = c->ext.actual->next->next->expr;
2659   ts.type = BT_INTEGER;
2660   ts.kind = gfc_c_int_kind;
2661
2662   /* handler can be either BT_INTEGER or BT_PROCEDURE  */
2663   if (handler->ts.type == BT_INTEGER)
2664     {
2665       if (handler->ts.kind != gfc_c_int_kind)
2666         gfc_convert_type (handler, &ts, 2);
2667       name = gfc_get_string (PREFIX ("signal_sub_int"));
2668     }
2669   else
2670     name = gfc_get_string (PREFIX ("signal_sub"));
2671
2672   if (number->ts.kind != gfc_c_int_kind)
2673     gfc_convert_type (number, &ts, 2);
2674   if (status != NULL && status->ts.kind != gfc_c_int_kind)
2675     gfc_convert_type (status, &ts, 2);
2676
2677   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2678 }
2679
2680
2681 /* Resolve the SYSTEM intrinsic subroutine.  */
2682
2683 void
2684 gfc_resolve_system_sub (gfc_code *c)
2685 {
2686   const char *name;
2687   name = gfc_get_string (PREFIX ("system_sub"));
2688   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2689 }
2690
2691
2692 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
2693
2694 void
2695 gfc_resolve_system_clock (gfc_code *c)
2696 {
2697   const char *name;
2698   int kind;
2699
2700   if (c->ext.actual->expr != NULL)
2701     kind = c->ext.actual->expr->ts.kind;
2702   else if (c->ext.actual->next->expr != NULL)
2703       kind = c->ext.actual->next->expr->ts.kind;
2704   else if (c->ext.actual->next->next->expr != NULL)
2705       kind = c->ext.actual->next->next->expr->ts.kind;
2706   else
2707     kind = gfc_default_integer_kind;
2708
2709   name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
2710   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2711 }
2712
2713
2714 /* Resolve the EXIT intrinsic subroutine.  */
2715
2716 void
2717 gfc_resolve_exit (gfc_code *c)
2718 {
2719   const char *name;
2720   int kind;
2721
2722   if (c->ext.actual->expr != NULL)
2723     kind = c->ext.actual->expr->ts.kind;
2724   else
2725     kind = gfc_default_integer_kind;
2726
2727   name = gfc_get_string (PREFIX ("exit_i%d"), kind);
2728   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2729 }
2730
2731
2732 /* Resolve the FLUSH intrinsic subroutine.  */
2733
2734 void
2735 gfc_resolve_flush (gfc_code *c)
2736 {
2737   const char *name;
2738   gfc_typespec ts;
2739   gfc_expr *n;
2740
2741   ts.type = BT_INTEGER;
2742   ts.kind = gfc_default_integer_kind;
2743   n = c->ext.actual->expr;
2744   if (n != NULL && n->ts.kind != ts.kind)
2745     gfc_convert_type (n, &ts, 2);
2746
2747   name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
2748   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2749 }
2750
2751
2752 void
2753 gfc_resolve_free (gfc_code *c)
2754 {
2755   gfc_typespec ts;
2756   gfc_expr *n;
2757
2758   ts.type = BT_INTEGER;
2759   ts.kind = gfc_index_integer_kind;
2760   n = c->ext.actual->expr;
2761   if (n->ts.kind != ts.kind)
2762     gfc_convert_type (n, &ts, 2);
2763
2764   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
2765 }
2766
2767
2768 void
2769 gfc_resolve_ctime_sub (gfc_code *c)
2770 {
2771   gfc_typespec ts;
2772
2773   /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
2774   if (c->ext.actual->expr->ts.kind != 8)
2775     {
2776       ts.type = BT_INTEGER;
2777       ts.kind = 8;
2778       ts.derived = NULL;
2779       ts.cl = NULL;
2780       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2781     }
2782
2783   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
2784 }
2785
2786
2787 void
2788 gfc_resolve_fdate_sub (gfc_code *c)
2789 {
2790   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
2791 }
2792
2793
2794 void
2795 gfc_resolve_gerror (gfc_code *c)
2796 {
2797   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
2798 }
2799
2800
2801 void
2802 gfc_resolve_getlog (gfc_code *c)
2803 {
2804   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
2805 }
2806
2807
2808 void
2809 gfc_resolve_hostnm_sub (gfc_code *c)
2810 {
2811   const char *name;
2812   int kind;
2813
2814   if (c->ext.actual->next->expr != NULL)
2815     kind = c->ext.actual->next->expr->ts.kind;
2816   else
2817     kind = gfc_default_integer_kind;
2818
2819   name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
2820   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2821 }
2822
2823
2824 void
2825 gfc_resolve_perror (gfc_code *c)
2826 {
2827   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
2828 }
2829
2830 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
2831
2832 void
2833 gfc_resolve_stat_sub (gfc_code *c)
2834 {
2835   const char *name;
2836   name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
2837   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2838 }
2839
2840
2841 void
2842 gfc_resolve_lstat_sub (gfc_code *c)
2843 {
2844   const char *name;
2845   name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
2846   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2847 }
2848
2849
2850 void
2851 gfc_resolve_fstat_sub (gfc_code *c)
2852 {
2853   const char *name;
2854   gfc_expr *u;
2855   gfc_typespec *ts;
2856
2857   u = c->ext.actual->expr;
2858   ts = &c->ext.actual->next->expr->ts;
2859   if (u->ts.kind != ts->kind)
2860     gfc_convert_type (u, ts, 2);
2861   name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
2862   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2863 }
2864
2865
2866 void
2867 gfc_resolve_fgetc_sub (gfc_code *c)
2868 {
2869   const char *name;
2870   gfc_typespec ts;
2871   gfc_expr *u, *st;
2872
2873   u = c->ext.actual->expr;
2874   st = c->ext.actual->next->next->expr;
2875
2876   if (u->ts.kind != gfc_c_int_kind)
2877     {
2878       ts.type = BT_INTEGER;
2879       ts.kind = gfc_c_int_kind;
2880       ts.derived = NULL;
2881       ts.cl = NULL;
2882       gfc_convert_type (u, &ts, 2);
2883     }
2884
2885   if (st != NULL)
2886     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
2887   else
2888     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
2889
2890   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2891 }
2892
2893
2894 void
2895 gfc_resolve_fget_sub (gfc_code *c)
2896 {
2897   const char *name;
2898   gfc_expr *st;
2899
2900   st = c->ext.actual->next->expr;
2901   if (st != NULL)
2902     name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
2903   else
2904     name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
2905
2906   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2907 }
2908
2909
2910 void
2911 gfc_resolve_fputc_sub (gfc_code *c)
2912 {
2913   const char *name;
2914   gfc_typespec ts;
2915   gfc_expr *u, *st;
2916
2917   u = c->ext.actual->expr;
2918   st = c->ext.actual->next->next->expr;
2919
2920   if (u->ts.kind != gfc_c_int_kind)
2921     {
2922       ts.type = BT_INTEGER;
2923       ts.kind = gfc_c_int_kind;
2924       ts.derived = NULL;
2925       ts.cl = NULL;
2926       gfc_convert_type (u, &ts, 2);
2927     }
2928
2929   if (st != NULL)
2930     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
2931   else
2932     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
2933
2934   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2935 }
2936
2937
2938 void
2939 gfc_resolve_fput_sub (gfc_code *c)
2940 {
2941   const char *name;
2942   gfc_expr *st;
2943
2944   st = c->ext.actual->next->expr;
2945   if (st != NULL)
2946     name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
2947   else
2948     name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
2949
2950   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2951 }
2952
2953
2954 void
2955 gfc_resolve_ftell_sub (gfc_code *c)
2956 {
2957   const char *name;
2958   gfc_expr *unit;
2959   gfc_expr *offset;
2960   gfc_typespec ts;
2961
2962   unit = c->ext.actual->expr;
2963   offset = c->ext.actual->next->expr;
2964
2965   if (unit->ts.kind != gfc_c_int_kind)
2966     {
2967       ts.type = BT_INTEGER;
2968       ts.kind = gfc_c_int_kind;
2969       ts.derived = NULL;
2970       ts.cl = NULL;
2971       gfc_convert_type (unit, &ts, 2);
2972     }
2973
2974   name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
2975   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2976 }
2977
2978
2979 void
2980 gfc_resolve_ttynam_sub (gfc_code *c)
2981 {
2982   gfc_typespec ts;
2983
2984   if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
2985     {
2986       ts.type = BT_INTEGER;
2987       ts.kind = gfc_c_int_kind;
2988       ts.derived = NULL;
2989       ts.cl = NULL;
2990       gfc_convert_type (c->ext.actual->expr, &ts, 2);
2991     }
2992
2993   c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
2994 }
2995
2996
2997 /* Resolve the UMASK intrinsic subroutine.  */
2998
2999 void
3000 gfc_resolve_umask_sub (gfc_code *c)
3001 {
3002   const char *name;
3003   int kind;
3004
3005   if (c->ext.actual->next->expr != NULL)
3006     kind = c->ext.actual->next->expr->ts.kind;
3007   else
3008     kind = gfc_default_integer_kind;
3009
3010   name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3011   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3012 }
3013
3014 /* Resolve the UNLINK intrinsic subroutine.  */
3015
3016 void
3017 gfc_resolve_unlink_sub (gfc_code *c)
3018 {
3019   const char *name;
3020   int kind;
3021
3022   if (c->ext.actual->next->expr != NULL)
3023     kind = c->ext.actual->next->expr->ts.kind;
3024   else
3025     kind = gfc_default_integer_kind;
3026
3027   name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3028   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3029 }