gcc/fortran/iresolve.c

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