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