gcc/fortran/iresolve.c

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